head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.17.31;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.11.58.50;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.54.38;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.30.04;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.10.34.54;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.39.20;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.31.58;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.31.52;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.16.38;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.16.10;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.30.33;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.14.19;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.20.40;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.05.12;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.52.14;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.16.00.11;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.17.17;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.09.49;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.54.12;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.36.26;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.57.34;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.42.19;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.34.14;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.47.58;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.25.38;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.41.03;  author dew;  state Exp;
branches ;
next     34.2;

34.2
date     89.02.01.09.55.17;  author bayes;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.16.18;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.47.48;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.56.54;  author bayes;  state Exp;
branches ;
next     31.2;

31.2
date     89.01.05.15.14.46;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.17.53;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.54.53;  author dew;  state Exp;
branches ;
next     29.2;

29.2
date     88.12.07.10.23.19;  author bayes;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.39.31;  author bayes;  state Exp;
branches ;
next     28.3;

28.3
date     88.10.31.10.40.11;  author bayes;  state Exp;
branches ;
next     28.2;

28.2
date     88.10.27.11.00.44;  author jwh;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.05.53;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.48.31;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.31.26;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.42.04;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.11.25;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.54.34;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.36.00;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.19.48;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.31.42;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.44.09;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.50.53;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.55.41;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.16.06.13;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.45.58;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.02.15.16.47;  author bayes;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.54.35;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.49.40;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.42.18;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.08.57;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.23.44;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.15.06.41;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.17.36;  author jws;  state Exp;
branches ;
next     7.2;

7.2
date     86.11.24.09.07.16;  author geli;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.26.51;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.22.49;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.10.06;  author hal;  state Exp;
branches ;
next     4.3;

4.3
date     86.10.28.12.38.44;  author hal;  state Exp;
branches ;
next     4.2;

4.2
date     86.10.08.09.10.45;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.20.06.25;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.16.47;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.15.05.47;  author hal;  state Exp;
branches ;
next     1.4;

1.4
date     86.07.30.13.22.16;  author geli;  state Exp;
branches ;
next     1.3;

1.3
date     86.07.03.14.18.29;  author geli;  state Exp;
branches ;
next     1.2;

1.2
date     86.07.01.08.42.56;  author geli;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.16.31.24;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@{modcal, code off,  search 'f'}

module fs;    {file support}

import sysglobals, asm, misc;

export

type
     closetype = (cnormal, lock, purge, ccrunch);
     faccess = (readonly,writeonly,readwrite,writeappend,overwrite);
     vptr = record case integer of
	      0: (j: integer);
	      1: (i: ^shortint);
	      2: (s: ^string80);
	      end;


procedure fstripname(s : fid; var pvname,ppath,pfname : string);
procedure fixname(var title: string; kind: filekind);
procedure zapspaces(var s: string);
function suffix(var ftitle: string): filekind;
function scantitle (fname: fid; var fvid: vid; var ftitle: fid;
			    var fsegs: integer; var fkind: filekind): boolean;
function findvolume (var fvid: vid; verify: boolean): unitnum;
procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);

procedure finitb (var f: fib; window: windowp; recbytes: integer);
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
procedure fhpreset(var f: fib; typ: faccess);
procedure fcloseit(var f: fib; stype: string255);
procedure fclose (var f: fib; ftype: closetype);
procedure fmaketype(anyvar f:fib; var title, option, typestring: string);
procedure foverfile(anyvar f:fib; var title, option, typestring: string);
procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);

procedure fseek(var f: fib; position: integer);
function fposition(var f: fib): integer;
function fmaxpos(var f: fib): integer;

function fbufferref(var f: fib): windowp;
procedure fget (var f: fib);
procedure fput (var f: fib);
function feof (var f: fib): boolean;
function feoln (var f: fib): boolean;
procedure fwriteln (var f: fib);

procedure fread(anyvar f: fib; anyvar buf: window);
procedure fwrite(anyvar f: fib;  anyvar buf: window);

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);

function fblockio (var f: fib; var buf: window;
			   nblocks,rblock: integer; doread: boolean): integer;


procedure killchar (anyvar f: fib; var sinx: integer);

procedure fpage (var t: text);
procedure foverprint(var t: text);
procedure fgotoxy(anyvar f: fib;      x, y:  integer);
procedure fgetxy (anyvar f: fib;  var x, y:  integer);

procedure freadln (var t:text);
procedure fwritechar (var t: text; ch: char; rleng: shortint);
procedure freadchar (var t:text; var ch: char);
procedure freadword (var t:text; var i: shortint);
procedure freadint (var t:text; var i: integer);
procedure fwriteword (var t:text;i,rleng: shortint);
procedure fwriteint (var t:text;i: integer; rleng: shortint);
procedure fwritestr (var t:text;anyvar s: string80; rleng: shortint);
procedure freadstr (var t:text; var s: string);
procedure fwritepaoc (var t: text; var a: window; aleng,rleng: shortint);
procedure freadpaoc (var t: text; var a: window; aleng: shortint);
procedure freadenum (var t: text; var i: shortint; p: vptr);
procedure fwriteenum(var t: text; i: shortint; rleng: shortint; p: vptr);
procedure freadbool (var t: text; var b: boolean);
procedure fwritebool(var t: text; b: boolean; rleng: shortint);


procedure freadstrchar (var s: string255;var p2: integer; var ch: char);
procedure fwritestrchar (var s: string;
				  var p2: integer; ch: char; rleng: shortint);
procedure freadstrword (var s: string255;var p2: integer; var i: shortint);
{PROCEDURE FREADSTRINT (VAR S: STRING255;VAR P2,I: INTEGER);}
procedure fwritestrword (var s: string;var p2: integer; i,rleng: shortint);
{PROCEDURE FWRITESTRINT(VAR T: STRING;
			       VAR P2: INTEGER; I: INTEGER; RLENG: SHORTINT); }
procedure freadstrstr (var t: string255;var p2: integer; var s: string);
procedure fwritestrstr (var s: string; var p2: integer;
					anyvar t: string255; rleng: shortint);
procedure fwritestrpaoc (var s: string; var p2: integer;
					var a: window; aleng,rleng: shortint);
procedure freadstrpaoc (var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
procedure freadstrenum (var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
procedure fwritestrenum(var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
procedure freadstrbool (var s: string255;var p2: integer; var b: boolean);
procedure fwritestrbool(var s: string;
				 var p2: integer; b: boolean; rleng: shortint);



implement

type  booltabletype = record
		      i: shortint;
		      t,f: string[5];
		      end;
      string1 = string[1];
const booltable = booltabletype[i:2, t:'TRUE', f:'FALSE'];
      nullstring = string1[''];

const special_eft = 0;   {disallowed efts for 3rd open parameter. SFB}
      dir_eft     = 3;

procedure zapspaces(var s: string);
var i,j: shortint;
    c: char;
begin
i := 1; j := 0;
while i <= strlen(s) do
  begin
  c := s[i];
  if (c > ' ') and (c <> chr(del)) then
    begin
    j := j + 1;
    s[j] := c;
    end;
  i := i + 1;
  end;
setstrlen(s, j);
end;

function suffix(var ftitle: string): filekind;
label 1;
var tail: suffixtype;
    i,j,k: shortint;
    fk: filekind;
begin
suffix := datafile;
j := strlen(ftitle);
for fk := untypedfile to lastfkind do
 begin
 k := strlen(suffixtable^[fk]);
 if (k > 0) and (j >= k+1) then
  if ftitle[j-k] = '.' then
    begin
    setstrlen(tail, k);
    for i := 1 to k do tail[i] := ftitle[j-k+i];
    upc(tail);
    if tail = suffixtable^[fk] then
      begin
      suffix := fk;
      goto 1;
      end;
    end;
 end;
1:
end;

function unitnumber(anyvar fvid:vid):boolean;
label   1;
var
  i     : integer;
begin
  unitnumber := false;
  if strlen(fvid)>0 then
   if fvid[1]='#' then
   begin
     for i := 2 to strlen(fvid) do
       if (fvid[i]<'0') or (fvid[i]>'9') then goto 1;
     unitnumber := true;
   end;
1:
end;

procedure fixname(var title: string; kind: filekind);
var i,j: integer;
      c: char;
     ok: boolean;
begin
  zapspaces(title);
  j := strlen(title);
  if j>0 then
   begin
   c := title[j];
   if c <> ':' then
    if c = '.' then setstrlen(title,j-1)
    else
     if not unitnumber(title) then
       if suffix(title) = datafile {i.e. no suffix} then
	 if strlen(suffixtable^[kind]) > 0 then
	   if j+1+strlen(suffixtable^[kind]) <= strmax(title) then
	     title := title + '.' + suffixtable^[kind];
   end;
end;

function scantitle(fname: fid; var fvid: vid; var ftitle: fid;
		   var fsegs: integer; var fkind: filekind);
var i,j,k: integer;

  procedure volume;
  var k: integer;
  begin
  setstrlen(fvid,j-1);  for k := 1 to j-1 do fvid[k] := fname[k];
  i := j;
  end;

procedure swapvolpass;
var
  k     : integer;
  doit  : boolean;
begin
  i := strpos(':',fname);
  if i > 1 then
    if fname[i-1] = '>' then
      begin
	j := strpos('<',fname);
	if (j > 0) and (j < i) then
	  if (j <= vidleng) and ((i-j) <= (passleng + 2)) then
	    begin
	      doit := true;
	      for k := j to i-2 do
		if fname[k] = '>' then
		  doit := false;
	      if doit then
		begin
		  for k := i-1 downto j do
		    fname[k+1] := fname[k];
		  fname[j] := ':';
		end;
	    end;
      end;
end;

begin   { scantitle }
fvid:=dkvid; ftitle:=''; fsegs:=0; scantitle := false; fkind := datafile;

zapspaces(fname);

if strlen(fname)>0 then     {some kind of file name is present}
 begin
 scantitle := true;

 {if an SRM volume password is to the left of the colon, move it to the right}
 swapvolpass;

 {extract volume name}
 i := 1;
 if      fname[1]='*' then begin
			    i := 2;
			    fvid:=syvid;
			    end
 else if fname[1]='#' then
   begin
   strread(fname,2,j,k);
   if ioresult = ord(inoerror) then
     begin
       scantitle := (k<=maxunit) and (k>0);
       if j>strlen(fname) then volume
       else if fname[j]=':' then volume
       else scantitle := false;
     end
   else scantitle := false;
   end
 else
   begin
   j := strpos(':',fname);
   if (j>1) and (j <= vidleng+1) then volume;
   end;

 if i<=strlen(fname) then if fname[i]=':' then i := i + 1;

 strdelete(fname, 1, i-1);     {zap volume name}

 {get file size specifier}
 j := strpos('[',fname);
 if (j>0) and (j<strlen(fname)) then
     begin
     i := j+1;
     if fname[i]='*' then
       begin
       fsegs := -1;
       i := i + 1;
       end
     else
       begin
       strread(fname,i,i,fsegs);
       if (ioresult <> ord(inoerror)) or (fsegs<0) then
	 begin
	   i := 0;
	   fsegs := 0;
	 end;
       end;
     if (i > 0) and (i<=strlen(fname)) then
       if fname[i]=']' then strdelete(fname,j,i+1-j)
       else fsegs := 0
     else fsegs :=0;
     end;

 {all the rest is FTITLE}
 ftitle := fname;

 fkind := suffix(fname);
 ioresult := ord(inoerror);
 end;
end; {SCANTITLE}

function findvolume(var fvid: vid; verify: boolean): unitnum;
var   lunit: unitnum;   ok: boolean;
      i: integer;
      upcname: vid;
begin
findvolume := 0; ok := false;
if strlen(fvid) > 0 then
  begin
    if fvid[1] = '#' then
	 begin
	 strread(fvid, 2, i, lunit);
	 ok := (i = strlen(fvid)+1) and (lunit > 0) and (lunit <= maxunit);
	 if ok then with unitable^[lunit] do
	     begin
	     call (dam, uvid, lunit, getvolumename);
	     if strlen(uvid) > 0 then fvid := uvid;
	     end;
	 end
    else begin
	 upcname := fvid;       upc(upcname);
	 i := 0;
	 repeat
	   lunit := maxunit;
	   repeat with unitable^[lunit] do
	     begin
	     if uuppercase  and odd(i) then ok := upcname = uvid { scs 2/08/83}
				       else ok :=    fvid = uvid;
	     if (ok and verify) or (i = 2) then                  { scs 2/08/83}
	       begin
	       call (dam, uvid, lunit, getvolumename);
	       if uuppercase and odd(i) then ok := upcname = uvid{ scs 2/08/83}
					else ok :=    fvid = uvid;
	       end;
	     if not ok then lunit := lunit-1;
	     end;
	   until ok or (lunit = 0);
	   i := i + 1;
	 until ok or (i > 3);                                    { scs 2/08/83}
	 end;
  end; {strlen(FVID)>0}

if ok then findvolume := lunit;
end (*FINDVOLUME*) ;


procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);
var
  lkind         : filekind;
  segs          : integer;
  lfib          : fib;

begin   {do prefix}
  ioresult := ord(inoerror);
  if (strlen(dirname)>0) then
  with lfib do
  begin
    if scantitle(dirname,fvid,ftitle,segs,lkind) then
      begin
      funit        := findvolume(fvid,true);
      if (funit = 0) or unitnumber(fvid) then
	if findunit then ioresult := ord(inounit)
	else if strlen(ftitle)>0 then ioresult := ord(ibadtitle)
	     else begin kvid    := fvid; ioresult := ord(inoerror); end
      else
	begin
	fkind      := lkind;
	fanonymous := false;
	pathid     := -1;
	call(unitable^[funit].dam,lfib,funit,setunitprefix);
	if ioresult = ord(inoerror) then
	   begin kvid := unitable^[funit].uvid; kunit := funit; end;
	end;
      end { scantitle ok }
    else ioresult:=ord(ibadtitle);
  end;  { with }
end;

(* FILE STATE HANDLERS *)

procedure initfibfields(var f: fib);
  begin with f do
    begin
    freadmode := false; fbufvalid := false;
    freadable := false; fwriteable := false;
    flockable := false; flocked := true;
    feoln := true;      feof := true;
    fb0 := false;       fb1 := false;
    fextra2 := 8; { default tab stops }
    end;
  end;

procedure finitb (var f: fib; window: windowp; recbytes: integer);
begin
with f do
  begin initfibfields(f);
  fwindow := window;  fistextvar := recbytes = -3;
  if recbytes = -1 then
    begin fwindow := nil; frecsize := 0 end
  else if recbytes <= 0 then
    begin
    fwindow^[1] := chr(0); frecsize := 1;
    end
  else frecsize := recbytes;
  fbuffered := frecsize > 0;
  end;
end (*FINITB*) ;

procedure parsename(var f: fib; var filetitle: string);
var kind: filekind;
begin
ioresult := ord(inoerror);
with f do
    if strlen(filetitle) > fidleng then ioresult := ord(ibadtitle)
    else if not scantitle(filetitle,fvid,ftitle,fpos,kind)
	 then ioresult := ord(ibadtitle)
    else fkind := kind;
end;

procedure setfilestate(var f: fib; typ: faccess);
begin with f do if ioresult = ord(inoerror) then
  begin
  fpos := 0;                  {reset file pointer to beginning}
  fbufvalid := false;         {clear lookahead buffer}
  case typ of
    readonly:
      begin feof := false; freadmode := true; feoln := true;
      freadable := true; fwriteable := false;
      end;
    readwrite:
      begin feof := false; freadmode := false;
      freadable := true; fwriteable := true;
      end;
    writeappend:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fpos := fleof;                          {seek to end of file}
      end;
    writeonly:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fleof := 0; fmodified := true;          {zap current contents of file}
      end;
    end;
  end;
end;


{------------------------------------------------------------------------}
{                                                                        }
{    The comments in this paragraph describe the changes made to         }
{    fileopen() to effect repair of FSDdt01559 - "Pascal does not        }
{    recognize write protect on diskettes".                              }
{                                                                        }
{    The error manifested itself as follows : when attempting to write   }
{    to an unwriteable medium SPECIFIED BY UNIT NUMBER, if there         }
{    happened to be a higher numbered volume on line of THE SAME NAME,   }
{    which was writeable, that higher numbered medium could be written   }
{    to. This would not be incorrect behavior had the medium been        }
{    specified by volume name. For the case of specification by unit     }
{    number, however, correct behavior would be to inform the user that  }
{    the specified medium could not be written and return an i/o error.  }
{                                                                        }
{    In order to select a unit when attempting to open a file, fileopen  }
{    calls findvolume() to return the unit number of the volume specified. }
{    In the case the volume is specified as a unit number, findvolume    }
{    has the side effect of modifying the volume name passed in (a       }
{    number) to the volume name corresponding to that number (in the     }
{    unit table). It is the nature (and rightly so, under most circum-   }
{    stances) for fileopen to make a second try at locating a unit       }
{    number should the DAM call (indexed from the first unit number      }
{    returned from findvolume) fail for any reason. However, at the      }
{    time of this second call to findvolume, WE HAVE LOST THE ORIGINAL   }
{    VOLUME SPECIFICATION AS A UNIT NUMBER. What we have instead as a    }
{    volume specifier is the volume name corresponding to the original   }
{    numeric volume specifier. Since findvolume does a backward search   }
{    through the unit table when searching for a unit SPECIFIED BY       }
{    VOLUME NAME, if there are any other volumes on line of the same     }
{    name as our originally specified volume, at a higher unit number,   }
{    findvolume will return a unit number different than originally      }
{    specified by the user ! If the medium corresponding to this unit    }
{    number is writeable, the wrong medium may be written to !           }
{                                                                        }
{    The fix implemented here is to not allow a second attempt at        }
{    finding a unit number when the first DAM call fails in the case     }
{    that the original volume specification was by unit number.          }
{                                                                        }
{    All the added lines of code are located in fileopen() and are       }
{    commented should for any reason (HA!) the repair needs to be        }
{    backed out.                                                         }
{                                                                        }
{                                         JWH - 10/27/88                 }

procedure fileopen(var f: fib; typ, styp: faccess;
			{additional parameter for Rev. 3.2}
			{added 30-Jun-86 geli}
			is_set_feft: boolean);
label   1,2,3;
var verify: boolean;
var is_unit_num : boolean;    { <=== ADDED 10/27/88 - JWH }
begin
if ioresult = ord(inoerror) then with f do
 begin
  lockup;
  try
  if fpos > 0 then fpos := fpos*fblksize;
  if not is_set_feft then
    feft := efttable^[fkind];
  fisnew := typ=writeonly;
  freptcnt := 0; fbufchanged := false; flastpos := -1;
  fstartaddress := 0;   pathid := -1;  fnosrmtemp := true;
  verify := false;
  is_unit_num := false;  { <=== ADDED 10/27/88 - JWH }
  if (fvid[1] = '#') then  { <=== ADDED 10/27/88 - JWH }
     is_unit_num := true;  { <=== ADDED 10/27/88 - JWH }
2:funit := findvolume(fvid,verify);
  if funit = 0 then ioresult := ord(inounit);
  if ioresult = 0 then
    with unitable^[funit] do
      begin                                       (*OK...OPEN UP FILE*)
      if not fisnew then           {try to open an existing file }
	begin
	if typ = overwrite then call (dam, f, funit, overwritefile)
			   else call (dam, f, funit, openfile);
	if ioresult <> ord(inoerror) then
	  if ((ioresult<>ord(inofile)) and (not verify) and (not is_unit_num))
	       then  { <=== ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else if (typ <> readonly) and (ioresult=ord(inofile))
		{added inofile check, as the only time we should create new file
		 for open or append is if file doesn't exist. If can't access
		 file, or can't access filesystem (eg ioresult=44), then just
		 exit with ioresult.
		 Note that overwritefile can create a new file which is "strange",
		 but SRMDAM and LIFDAM do it, returning inoerror. Could cause
		 problems on SRM if file disappears after EDITOR of FILER
		 detects its existence.
		 Fixes FSDdt02098. SFB/RDQ 01/05/89}
	   then fisnew := true else goto 1
	else if typ <> readonly then
	  begin
	  if fpos > fpeof then
	    begin
	    call (dam, f, funit, stretchit);
	    if fpos > fpeof then
	      begin
	      if typ = overwrite then call (dam, f, funit, purgefile);
	      ioresult := ord(icantstretch);
	      goto 1;
	      end;
	    end;
	  if typ = overwrite then goto 3;
	  end;
	end;
      if typ = readwrite then if fistextvar then
	begin
	if not fisnew then call (dam, f, funit, closefile);
	ioresult := ord(ibadfiletype); goto 1;
	end;
      if fisnew then               {try to make a new file}
	begin
	call (dam, f, funit, createfile);
	if ioresult <> ord(inoerror) then
	  if ((not verify) and (not is_unit_num)) then  { <=== 10/27/88 }
	     { ^ ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else goto 1;
	end;
   3: fmodified := fisnew;
      end;
1:setfilestate(f,styp);
  recover begin lockdown; escape(escapecode); end;
  lockdown;
 end;
end; {FILEOPEN}

procedure fclose (var f: fib; ftype: closetype);
label 1;
var  oldio : integer;                                   {rdq 14/sep/83 }
begin
  lockup;
  try
  ioresult := ord(inoerror); oldio:=ioresult;           {rdq}
  with f do
    if freadable or fwriteable then
      begin
	if fanonymous or (ftype = purge) or (fisnew and (ftype = cnormal))
	then call (unitable^[funit].dam, f, funit, purgefile)
	else
	  begin
	  if flocked then
	    begin
	    call (am, addr(f), flush, f, 0 , 0); oldio:=ioresult;       {rdq}
	    if (ioresult <> ord(inoerror)) and
	       (ioresult <> ord(inoaccess)) then goto 1;        {rdq 14/sep/83}
	    {set logical end of file to current file position}
	    if ftype = ccrunch then if fleof <> fpos then
		 begin
		 if fpos > fpeof then
		   begin
		   call (unitable^[funit].dam, f, funit, stretchit);
		   if fpos > fpeof then
		     begin ioresult := ord(icantstretch); goto 1; end;
		   end;
		 fleof := fpos; fmodified := true;
		 end;
	    end;
	  call (unitable^[funit].dam, f, funit, closefile);
	  end;
	initfibfields(f);
      end;
      if oldio<>ord(inoerror) then ioresult:=oldio;             {rdq 14/sep/83}
1:recover begin lockdown; escape(escapecode); end;
  lockdown;
end (*FCLOSE*) ;

procedure fcloseit(var f: fib; stype: string255);
  var s: string255; k: shortint; ch: char; ok: boolean;
      ftype: closetype;
begin
with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen) else
    begin
    s := stype; k := 1;
    while k <= strlen(s) do
      begin ch := s[k];
      if ch <= ' ' then strdelete(s,k,1)
      else
	begin
	if  (ch>='a') and (ch<='z') then
	  s[k] := chr(ord(ch)+(ord('A')-ord('a')));
	k := k+1;
	end;
      end;
    ok := true;
    if (s = 'NORMAL') or (s = 'TEMP') then
      ftype := cnormal
    else if (s = 'LOCK') or (s = 'SAVE') then
      ftype := lock
    else if s = 'PURGE' then ftype := purge
    else if s = 'CRUNCH' then ftype := ccrunch
    else
      begin ioresult := ord(ibadclose); ok := false end;
    if ok then fclose(f,ftype);
    end;
end; {fcloseit}

procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);
begin
  f.fanonymous := true;
  parsename(f, name);
  f.fkind := kind;
  f.fpos := size;
  f.foptstring := addr(nullstring);
  fileopen(f,writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure fhpreset(var f: fib; typ: faccess);
begin {fhpreset}
ioresult := ord(inoerror);
with f do
  if not (freadable or fwriteable) then
     begin
     fanonymous := true;
     fvid := syvid;
     fkind := datafile;
     fpos := -1;
     foptstring := addr(nullstring);
     fileopen(f, writeonly, typ,false); {changed 30-Jun-86 geli}
     end
  else setfilestate(f,typ);
end;

(***************************************************************************)
(* This routine parses an option string input via the 3rd parameter in a   *)
(* Pascal open, reset, rewrite and append 'system' call. The option string *)
(* is splitted into a 'damoption' part and a 'typeinfo' part. The damoption*)
(* part is passed to the DAM with the fib field foptstring. The other part *)
(* gets parsed in the fs.                                                  *)
(* The return values are : FALSE if option contains no typeinfo part       *)
(*                         TRUE  if option contains typeinfo part          *)
(*                                                                         *)
(* Author: Angelika Hierath                                                *)
(*         30-Jun-86                                                       *)
(*                                                                         *)
(***************************************************************************)
function parseoption( option: string255;
		      var damoption, typeinfo: string255): boolean;

var i : integer;        {actual position in option}
    state : integer;
    done: boolean;

begin
  (* initialisation of variables *)
  parseoption := false;
  i := 1;
  done := false;
  setstrlen(damoption,0);
  setstrlen(typeinfo,0);
  state := 1;

  (* if there is an option string do *)
  if strlen(option) <> 0 then
    repeat
      case state of
      1: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,damoption,strlen(damoption)+1)
	     else
	       state := 2;
	     i := i+1;
	   end
	 else
	   done := true;
      2: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       begin
		 strmove(1,option,i,typeinfo,strlen(typeinfo)+1);
		 state := 3;
		 parseoption := true;
	       end
	     else
	       begin
		 strappend(damoption,'\');
		 state := 1;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      3: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,typeinfo,strlen(typeinfo)+1)
	     else
	       begin
		 strmove(strlen(option)-i,option,i+1,damoption,strlen(damoption)+1);
		 done := true;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      end;
    until done;              {until at end of option string}
end;

(**********************************************************************)
(* This routine parses a typeinfo string. It checks whether there is a*)
(* suffix or a file type present. The possible suffixes are according *)
(* to the ones described in the Pascal Designers Guide section File   *)
(* system. They can be in any combination of upper and lower case     *)
(* letters. The file type can be any integer number that fits into a  *)
(* shortint (-32K..32k). If the typeinfo string doesn't contain a     *)
(* valid suffix or filetype, fkind gets set to datafile.              *)
(* (\0\ and \3\ are not valid, for various good reasons. It is        *)
(* confusing to see, for example, a "directory" on HFS that has a     *)
(* WSheader, and isn't really a directory as far as the DAM is        *)
(* concerned. Ditto special files. Therefore, we don't allow these    *)
(* to be made with the third parameter. SFB)                          *)
(* Otherwise fkind gets set according to the given suffix. If there   *)
(* is a file type present the variable feft gets assigned this        *)
(* value and fkind gets set accordingly.                              *)
(*                                                                    *)
(* The return values are  FALSE: if there was no file type given      *)
(*                        TRUE : if typeinfo contained a file type    *)
(*                                                                    *)
(* Author: Angelika Hierath                                           *)
(*         10-Jun-86                                                  *)
(*                                                                    *)
(**********************************************************************)

function parse_tinfo(typeinfo: string255;
		     var fkind: filekind;var feft: shortint): boolean;

var pos: integer;
    fk: filekind;

begin
  fkind := datafile;
  parse_tinfo := false;

    strread(typeinfo,1,pos,feft);
    if ioresult = ord(inoerror) then     (* got numeric, maybe valid *)
     begin
      if (feft<>special_eft) and (feft<>dir_eft) then {not special files/dirs SFB}
       begin
	 for fk := untypedfile to lastfkind do
	   if efttable^[fk] = feft then
	     fkind := fk;
	 parse_tinfo := true;
       end  {if (feft... SFB}
      end
    else
      begin
	ioresult := ord(inoerror);
	for fk := untypedfile to lastfkind do
	begin
	  upc(typeinfo);
	  if typeinfo = suffixtable^[fk] then
	      fkind := fk;
	end;
      end;
end;

{ this routine changed for revision 3.2. It is now possible to pass   }
{ a external file type in the option string. A file gets then created }
{ with this eft no matter which suffix is there on the file name      }
{ added 30-Jun-86 geli }
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
var damoption, typeinfo: string255;
    feft_flag: boolean;
    kind: filekind;

begin
 {initialize local variables}
 setstrlen(damoption,0);
 setstrlen(typeinfo,0);
 feft_flag := false;

 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);

 {parse option string; this part is new for revision 3.2 added 30-Jun-86 geli}
 if parseoption(option, damoption,typeinfo) then
   begin
     feft_flag := parse_tinfo(typeinfo,kind,f.feft);
     f.fkind := kind;
     f.foptstring := addr(damoption);
   end
 else
   f.foptstring := addr(option);
 fileopen(f,typ,typ,feft_flag);     {changed 30-Jun-86 geli}
end;

procedure fmaketype(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure foverfile(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, overwrite, writeonly,false);       {changed 30-Jun-86 geli}
end;


{file positioning primitives}

procedure fseek(var f: fib; position: integer);
begin with f do
  if not (freadable and fwriteable and flocked) then
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not(freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked)
  else if position < 1 then ioresult := ord(ibadvalue)          { scs 2/08/83 }
  else begin
       ioresult := ord(inoerror);
      {if position < 1 then fpos := 0                            scs 1/17/83
       else}
       fpos := (position - 1) * frecsize;
       freadmode := false; fbufvalid := false;  {non read mode condition}
       end;
end;

function fposition(var f: fib): integer;
begin
with f do
  if (freadable or fwriteable) and flocked then
    begin ioresult := ord(inoerror);
    fposition := fpos div frecsize + 1 - ord(fbufvalid);
    end
  else
    begin
    if not(freadable or fwriteable) then ioresult := ord(inotopen)
    else ioresult := ord(ifileunlocked);
    fposition := 0;
    end;
end;

function fmaxpos(var f: fib): integer;
begin with f do
  if freadable and fwriteable and flocked then
       begin ioresult := ord(inoerror);
       fmaxpos := fleof div frecsize;
       end
  else begin
       fmaxpos := 0;
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not (freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked);
       end;
end;


{PASCAL I/O primitives}

function fbufferref(var f: fib): windowp;
begin
with f do
 begin
 fbufferref := fwindow;                         {primary objective}
 if freadmode and not fbufvalid and flocked then {lazy I/O condition}
   begin
   call (am, addr(f), readbytes, fwindow^, frecsize, fpos);
   if ioresult = ord(ieof) then
     begin
     feof := true;
     if not feoln then
       begin
       fwindow^[0] := ' ';
       feoln := true;                           {create 'GHOST' end of line}
       fbufvalid := true;
       ioresult := ord(inoerror);
       end
     end
   else begin fbufvalid := true; feof := false; end;
   end
 else if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not flocked then ioresult := ord(ifileunlocked)
	   else ioresult := ord(inoerror);
 end;
end;

procedure fget(var f: fib);
begin
with f do
  if freadmode and not fbufvalid then fread(f, f.fwindow^)
						{set lazy I/O condition}
  else if not (freadable and flocked) then
	  if not (freadable or fwriteable) then ioresult := ord(inotopen)
	  else if not freadable then ioresult := ord(inotreadable)
	       else ioresult := ord(ifileunlocked)
       else  begin ioresult := ord(inoerror);
	     freadmode := true;  fbufvalid := false; {set lazy I/O condition}
	     end;
end;

procedure fput (var f: fib);
begin
  fwrite(f, f.fwindow^);                        {set non read mode condition}
end;

function feof (var f: fib);
var x: windowp;
begin
ioresult := ord(inoerror);  feof := true;       {bug fix rdq 10/13/83}
if f.flocked then
  if f.freadable or f.fwriteable then
    if f.frecsize <= 0 then feof := f.fpos >= f.fleof     {untyped files}
    else if f.freadable and f.fwriteable then feof := fposition(f)>fmaxpos(f)
	 else begin
	      if not unitable^[f.funit].uisinteractive then x := fbufferref(f);
	      if ioresult = ord(ieof) then ioresult := ord(inoerror);
	      feof := f.feof;
	      end
  else ioresult := ord(inotopen) {bug fix rdq 9/12/83}
else ioresult := ord(ifileunlocked)
end;

function feoln (var f: fib);
var x: windowp;
begin
  x := fbufferref(f);
  if ioresult = ord(ieof) then ioresult := ord(inoerror);
  feoln := f.feoln;
end;

procedure fwriteln (var f: fib);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call(am, addr(f), writeeol, fbuffer, 0, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end (*FWRITELN*) ;


{sequential record I/O }

procedure fread(anyvar f: fib; anyvar buf: window);
begin with f do
if fbufvalid and flocked then
    begin ioresult := ord(inoerror);            {look ahead condition}
    if frecsize = 1 then buf[0] := fwindow^[0]  {a common case}
    else moveleft(fwindow^, buf, frecsize);
    fbufvalid := false;                         {set lazy I/O condition}
    end
else
    if not (freadable and flocked) then
	 if not (freadable or fwriteable) then ioresult := ord(inotopen)
	 else if not freadable then ioresult := ord(inotreadable)
	      else ioresult := ord(ifileunlocked)
    else begin
	 call (am, addr(f), readbytes, buf, frecsize, fpos);
	 freadmode := true; fbufvalid := false;   {set lazy I/O condition}
	 if ioresult = ord(ieof) then
	  if fistextvar and not feoln then
	    begin
	    buf[0] := ' ';
	    feoln := true;                      {'GHOST' end of line}
	    ioresult := ord(inoerror);
	    end;
	 end;
end;

procedure fwrite(anyvar f: fib;  anyvar buf: window);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call (am, addr(f), writebytes, buf, frecsize, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end;


{sequential binary I/O }

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
var i: integer;
begin with f do
  if not (freadable and flocked) then
       if not (freadable or fwriteable) then ioresult := ord(inotopen)
       else if not freadable then ioresult := ord(inotreadable)
	    else ioresult := ord(ifileunlocked)
  else begin
       call (am, addr(f), readbytes, buf, size, fpos);
       freadmode := true; fbufvalid := false;   {set lazy I/O condition}
       end;
end;

procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);
begin with f do
 if not (fwriteable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not fwriteable then ioresult := ord(inotwriteable)
	   else ioresult := ord(ifileunlocked)
 else begin
      call (am, addr(f), writebytes, buf, size, fpos);
      freadmode := false;    fbufvalid := false;    {set non read mode}
      end;
end;



{UCSD BLOCKREAD AND BLOCKWRITE FUNCTIONS}

function fblockio (var f: fib; var buf: window;
			  nblocks, rblock: integer; doread: boolean): integer;
var blockbytes, filebytes: integer;
begin with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen)
  else if not flocked then ioresult := ord(ifileunlocked)
  else
    begin
    ioresult := ord(inoerror);
    if rblock >= 0 then fpos := rblock*fblksize
		   else fpos := fpos + (-fpos) mod fblksize;
    blockbytes := nblocks*fblksize;
    if doread then
	 begin
	 filebytes := fleof - fpos;
	 if filebytes < 0 then filebytes := 0;
	 if filebytes < blockbytes then
	   begin blockbytes := filebytes;
		 nblocks := (filebytes+(fblksize-1)) div fblksize;
	   end;
	 if blockbytes > 0 then
			call (am, addr(f), readbytes,  buf, blockbytes, fpos);
	 end
    else if blockbytes > 0 then
			call (am, addr(f), writebytes, buf, blockbytes, fpos);
    if ioresult = 0 then fblockio := nblocks  else fblockio := 0;
    end;
end;


(* This routine is useful when input can be edited *)

procedure killchar (anyvar f: fib; var sinx: integer);
var c: char;
begin
c :=  fbufferref(f)^[0];
with f, unitable^[funit]  do
  if c = chr(bs) then
    begin
    if sinx > 0 then
	 begin
	 sinx := sinx - 1;                {DELETE LAST CHARACTER FROM INPUT}
	 if uisinteractive then
	   call (am, addr(f), writebytes,
			   windowp(addr(' '#8))^, 2, 0);  {CLEAR LAST CHAR }
	 end
    else if uisinteractive then
	      call (am, addr(f), writebytes,
			   windowp(addr(#28' '))^, 1, 0);  {FIXUP CURSOR}
    end
  else if c = chr(del) then
    begin
    if uisinteractive then
      begin
      sinx := sinx + 1;                         {DEL IS A PRINTABLE CHARACTER}
      while sinx > 0 do
	begin
	call (am, addr(f), writebytes,
			   windowp(addr( #8' '#8))^, 3, 0);   {ZAP OUT LINE}
	sinx := sinx - 1;
	end;
      end;
    sinx := 0;
    end
  else sinx := sinx + 1;                        {CHARACTER OK};
fget(f);                                    {ABSORB THE CHARACTER}
end;


		       (* DEVICE CONTROL INTRINSICS *)

procedure fpage (var t: text);
begin write(t, eol, clearscr);
end;

procedure foverprint(var t: text);
begin write(t, eol);
end;

procedure fgotoxy(anyvar f: fib;      x, y:  integer);
begin
  with f do
    begin
    fxpos := x;         fypos := y;
    call(am, addr(f), setcursor, f, 0, 0);
    end;
end;

procedure fgetxy (anyvar f: fib;  var x, y:  integer);
begin
  with f do
    begin
    call(am, addr(f), getcursor, f, 0, 0);
    x := fxpos;         y := fypos;
    end;
end;


			  (* TEXT FILE INTRINSICS *)

procedure freadln (var t: text);
var index: integer;
begin
index := 0;
while not eoln(t) do killchar(t, index);        {handle characters typed}
get(t);                                         {dispose of end of line}
end (*FREADLN*) ;

procedure freadchar (var t:text; var ch: char);
begin
  fread(t, ch);              {a compiler optimization is in order here! }
end (*FREADCHAR*) ;

procedure fwritechar(var t: text; ch: char; rleng: shortint);
var s: packed array[1..255] of char;  i: integer;
begin
if rleng < 1 then rleng := 1 else for i := 1 to rleng - 1 do s[i] := ' ';
s[rleng] := ch;
fwritebytes(t, s, rleng);
end;

procedure freadword (var t:text; var i: shortint);
var  n: integer;
begin
read(t,n);      if (n<-32768) or (n>32767) then escape(-8);
i:=n;
end;

procedure freadint (var t:text; var i: integer);
label 1,2,3,4;
const maxdigits = 255;
var s: string[maxdigits];
    characters, spaces, nonspaces: integer;
    c: char;
begin
characters := 0; spaces := 0;
setstrlen(s,maxdigits);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^;        if ioresult <> 0 then goto 1;              { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; characters := characters + 1;
  get(t); c := t^; if ioresult <> 0 then goto 1;
  end;
nonspaces := 0;
if (c='-') or (c='+') then
  begin
  nonspaces := 1; s[1] := c;
  characters := characters + 1;
  get(t);  c := t^; if ioresult <> 0 then goto 1;
  end;
3: while (c>='0') and (c<='9') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  characters := characters + 1;
  c := t^; if ioresult <> 0 then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, characters);
  c := t^; if ioresult <> 0 then goto 1;
  if characters <= spaces then begin spaces := characters; goto 2; end
  else begin nonspaces := characters - spaces; goto 3; end;
  end;
4: setstrlen(s,nonspaces);
strread(s, 1, characters, i);
1:
end;

procedure fwriteword(var t:text; i,rleng: shortint);
begin  fwriteint(t,i,rleng)  end;

procedure fwriteint(var t:text; i: integer; rleng: shortint);
var   s: string255; j: integer;
begin setstrlen(s,0);
strwrite(s,1,j,i:rleng);
if ioresult = ord(inoerror) then fwritebytes(t, s[1], strlen(s));
end (*FWRITEINT*) ;

procedure fwritestr(var t: text; anyvar s: string80; rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := strlen(s)
  else if rleng > strlen(s) then
    begin
    fwritechar(t,' ',rleng-strlen(s));
    rleng := strlen(s);
    end;
  fwritebytes(t, s[1], rleng);
end (*FWRITESTR*);

procedure readpacstr(var t: text; anyvar p: window;
					   var len: integer; maxlen: integer);
label 1,2;
var   sinx: integer;   c: char;
begin
len := 0;
with fibp(addr(t))^ do
if not (freadable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not freadable then ioresult := ord(inotreadable)
	   else ioresult := ord(ifileunlocked)
else
 begin
 if unitable^[funit].uisinteractive then
   begin
   sinx := 0;
   repeat
     c := t^;
     if feoln or (ioresult <> ord(inoerror)) then goto 2;
     if (c=chr(bs)) or (c=chr(del)) then  killchar(t, sinx)
     else begin get(t); p[sinx] := c; sinx := sinx + 1; end;
   until sinx >= maxlen;
   2: len := sinx;
   end
 else
   begin
   c := t^;
   if (ioresult = ord(inoerror)) and not feoln then
     begin
     get(t); len := 1;
     if maxlen > 1 then
       begin
       call(am, addr(t), readtoeol, p[0], maxlen-1, fpos);
       if ioresult = ord(inoerror) then len := len + ord(p[0]);
       end;
     p[0] := c;
     end;
   end;
 end;
1:
end;

procedure freadstr(var t:text; var s: string);
var len: integer;
begin
 readpacstr(t, s[1], len, strmax(s));
 setstrlen(s, len);
end; (*FREADSTR*)

procedure freadpaoc(var t: text; var a: window; aleng: shortint);
  var sinx: integer;
begin
  readpacstr(t, a, sinx, aleng);
  while sinx < aleng do begin a[sinx] := ' ';sinx := sinx+1; end;
end; {freadpaoc}

procedure fwritepaoc(var t: text;  var a: window; aleng,rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := aleng
  else if rleng > aleng then
    begin
    fwritechar(t,' ',rleng-aleng);
    rleng := aleng;
    end;
  fwritebytes(t, a, rleng);
end (*FWRITEPAOC*) ;

procedure fwriteenum(var t: text; i,rleng: shortint; p: vptr);
var s: string255; dummy: integer;
begin setstrlen(s,0); dummy := 1;
fwritestrenum(s,dummy,i,rleng,p);
if ioresult = ord(inoerror) then fwritebytes(t,s[1],strlen(s));
end;

procedure freadenum(var t: text; var i: shortint; p: vptr);
label 1,2,3,4;
var s: string255;
    sinx, spaces, nonspaces: integer; c: char;
begin
sinx := 0; spaces := 0;
setstrlen(s, 255);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^; if ioresult <> ord(inoerror) then goto 1;         { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
nonspaces := 0;
if ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z')) then
  begin
  nonspaces := 1; s[1] := c;
  sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
3: while ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z'))
      or ((c>='0') and (c<='9')) or (c = '_') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  sinx := sinx + 1; c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, sinx);
  c := t^; if ioresult <> ord(inoerror) then goto 1;
  if sinx <= spaces then  begin spaces := sinx; goto 2; end
  else  begin nonspaces := sinx - spaces; goto 3; end;
  end;
4: setstrlen(s, nonspaces); sinx := 1;
freadstrenum(s, sinx, i, p);
1:
end;

procedure fwritebool(var t: text; b: boolean; rleng: shortint);
var p: vptr;
begin
  p.i := addr(booltable);
  fwriteenum(t,ord(b),rleng,p);
end;

procedure freadbool(var t: text; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadenum(t,i,p);
  b := i=1;
end;


	(*  STRING I/O INTRINSICS *)

procedure freadstrchar(var s: string255; var p2: integer; var ch: char);
begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else  begin ioresult := ord(inoerror);
      ch := s[p2]; p2 := p2+1;
      end;
end;

procedure fwritestrchar(var s: string; var p2: integer;
						   ch: char; rleng: shortint);
var t: string[1];
begin setstrlen(t,1);
t[1] := ch;
if rleng < 1 then rleng := 1;
fwritestrstr(s,p2,t,rleng);
end;

procedure fwritestrint $alias 'FS_FWRITESTRINT'$
      (var t: string; var p2: integer; i: integer; rleng: shortint); external;

procedure fwritestrword(var s: string; var p2: integer; i,rleng: shortint);
begin
   fwritestrint(s,p2,i,rleng);
end;

procedure freadstrword(var s: string255;var p2: integer; var i: shortint);
var n: integer;
begin
strread(s,p2,p2,n);
if (n<-32768) or (n>32767) then escape(-8);
i := n;
end;

{procedure freadstrint(var s: string255; var p2, i: integer);
external; }

procedure fwritestrstr(var s: string;
		       var p2: integer; anyvar t: string255; rleng: shortint);
var i,tp2: integer;
begin ioresult := ord(inoerror);
if rleng <> 0 then
  begin tp2 := p2;
  if rleng < 0 then rleng := strlen(t);
  if (tp2<1) or (tp2>strlen(s)+1) then ioresult := ord(istrovfl)
  else if tp2+rleng-1>strmax(s) then
    ioresult := ord(istrovfl)
  else
    begin
    if rleng > strlen(t) then
      begin
      for i := tp2 to tp2-1+rleng-strlen(t) do s[i] := ' ';
      tp2 := tp2+rleng-strlen(t);
      end;
    if rleng > strlen(t) then rleng := strlen(t);
    moveleft(t[1],s[tp2],rleng);
    tp2 := tp2+rleng;
    if tp2-1 > strlen(s) then setstrlen(s,tp2-1);
    p2 := tp2;
    end;
  end;
end; {fwritestrstr}

procedure freadstrstr(var t: string255; var p2: integer; var s: string);
  label 1;
  var sx,k: shortint;
  begin
  sx := 0; setstrlen(s,0);
  if (p2 < 1) or (p2 > strlen(t)) then ioresult := ord(istrovfl)
  else
    begin ioresult := ord(inoerror);
    for k := p2 to strlen(t) do
      begin
      if sx >= strmax(s) then goto 1;
      sx := sx+1; s[sx] := t[k];
      end;
 1: setstrlen(s,sx); p2 := p2+sx;
    end;
  end;

procedure fwritestrpaoc(var s: string;
    var p2: integer; var a: window; aleng,rleng: shortint);
var t: string255;
begin
setstrlen(t,aleng);
moveleft(a,t[1],aleng);
fwritestrstr(s,p2,t,rleng);
end;


procedure freadstrpaoc(var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
label 1;
var i,ainx,sinx: integer;
begin sinx := p2;
if (sinx<1) or (sinx > strlen(s)) then ioresult := ord(istrovfl)
else
  begin ioresult := ord(inoerror);
  for i := 0 to aleng-1 do a[i] := ' ';
  for ainx := 0 to aleng-1 do
    begin
    if sinx > strlen(s) then goto 1;
    a[ainx] := s[sinx];
    sinx := sinx+1;
    end;
  end;
1: if ioresult = ord(inoerror) then p2 := sinx;
end;

procedure freadstrenum(var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
label 1;
const idlength = 80;
var t: string[idlength];
    q, j, tinx: integer; c: char;
    done: boolean;

begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else
  begin
  q := p2;
  while s[q] = ' ' do
    begin
    q := q + 1;
    if q > strlen(s) then begin ioresult := ord(istrovfl); goto 1; end;
    end;
  c := s[q];
  if ((c < 'A') or (c > 'Z')) and ((c < 'a') or (c > 'z')) then
	      begin ioresult := ord(ibadformat); goto 1; end;
  ioresult := ord(inoerror);
  tinx := 0; setstrlen(t, idlength);
  done := false;
  repeat
    tinx := tinx+1;
    t[tinx] := c;
    q := q + 1;
    if (q > strlen(s)) or (tinx = idlength) then done := true
    else begin c := s[q];
	 done := not (((c>='A') and (c<='Z')) or ((c>='a') and (c<='z'))
		   or ((c>='0') and (c<='9')) or (c = '_'));
	 end;
  until done;

  setstrlen(t, tinx); upc(t);
  j := p.i^-1; p.j := p.j+ sizeof(shortint);
  while p.s^<>t do
    begin
    j := j-1;
    if j < 0 then begin ioresult := ord(ibadformat); goto 1; end;
    p.j := p.j + strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  i := j; p2 := q;
  end;
1:
end; {freadenum}


procedure fwritestrenum (var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
var k: shortint;
begin
if (i<0) or (i>=p.i^) then escape(-8)
else
  begin ioresult := ord(inoerror);
  k := p.i^-1;  {index of 1st entry}
  p.j := p.j+2;
  while k>i do
    begin k := k-1;
    p.j := p.j+strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  fwritestrstr(s,p2,p.s^,rleng);
  end;
end; {fwritestrenum}

procedure fwritestrbool (var s: string;
				 var p2: integer; b: boolean; rleng: shortint);
var p: vptr;
begin
p.i := addr(booltable);
fwritestrenum(s,p2,ord(b),rleng,p);
end;

procedure freadstrbool(var s: string255; var p2: integer; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadstrenum(s,p2,i,p);
  b := i=1;
end;

procedure fstripname(s : fid; var pvname,ppath,pfname : string);
var
  tempfib : fib;
  lkind   : filekind;
  segs    : integer;
begin
  with tempfib do
  begin
    if scantitle(s,fvid,ftitle,segs,lkind) then
    begin
      funit := findvolume(fvid,true);
      if funit=0 then ioresult := ord(inounit)
      else
      begin
	call(unitable^[funit].dam,tempfib,funit,stripname);
	if ioresult=ord(inoerror) then
	begin
	  pvname := fvid;
	  ppath  := ftitle;
	  pfname := ftid;
	end;
      end;
    end
    else ioresult := ord(ibadtitle);
  end; { with }
end;

end  {file support}


@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 1624
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 1624
{modcal, code off,  search 'f'}

module fs;    {file support}

import sysglobals, asm, misc;

export

type
     closetype = (cnormal, lock, purge, ccrunch);
     faccess = (readonly,writeonly,readwrite,writeappend,overwrite);
     vptr = record case integer of
	      0: (j: integer);
	      1: (i: ^shortint);
	      2: (s: ^string80);
	      end;


procedure fstripname(s : fid; var pvname,ppath,pfname : string);
procedure fixname(var title: string; kind: filekind);
procedure zapspaces(var s: string);
function suffix(var ftitle: string): filekind;
function scantitle (fname: fid; var fvid: vid; var ftitle: fid;
			    var fsegs: integer; var fkind: filekind): boolean;
function findvolume (var fvid: vid; verify: boolean): unitnum;
procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);

procedure finitb (var f: fib; window: windowp; recbytes: integer);
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
procedure fhpreset(var f: fib; typ: faccess);
procedure fcloseit(var f: fib; stype: string255);
procedure fclose (var f: fib; ftype: closetype);
procedure fmaketype(anyvar f:fib; var title, option, typestring: string);
procedure foverfile(anyvar f:fib; var title, option, typestring: string);
procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);

procedure fseek(var f: fib; position: integer);
function fposition(var f: fib): integer;
function fmaxpos(var f: fib): integer;

function fbufferref(var f: fib): windowp;
procedure fget (var f: fib);
procedure fput (var f: fib);
function feof (var f: fib): boolean;
function feoln (var f: fib): boolean;
procedure fwriteln (var f: fib);

procedure fread(anyvar f: fib; anyvar buf: window);
procedure fwrite(anyvar f: fib;  anyvar buf: window);

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);

function fblockio (var f: fib; var buf: window;
			   nblocks,rblock: integer; doread: boolean): integer;


procedure killchar (anyvar f: fib; var sinx: integer);

procedure fpage (var t: text);
procedure foverprint(var t: text);
procedure fgotoxy(anyvar f: fib;      x, y:  integer);
procedure fgetxy (anyvar f: fib;  var x, y:  integer);

procedure freadln (var t:text);
procedure fwritechar (var t: text; ch: char; rleng: shortint);
procedure freadchar (var t:text; var ch: char);
procedure freadword (var t:text; var i: shortint);
procedure freadint (var t:text; var i: integer);
procedure fwriteword (var t:text;i,rleng: shortint);
procedure fwriteint (var t:text;i: integer; rleng: shortint);
procedure fwritestr (var t:text;anyvar s: string80; rleng: shortint);
procedure freadstr (var t:text; var s: string);
procedure fwritepaoc (var t: text; var a: window; aleng,rleng: shortint);
procedure freadpaoc (var t: text; var a: window; aleng: shortint);
procedure freadenum (var t: text; var i: shortint; p: vptr);
procedure fwriteenum(var t: text; i: shortint; rleng: shortint; p: vptr);
procedure freadbool (var t: text; var b: boolean);
procedure fwritebool(var t: text; b: boolean; rleng: shortint);


procedure freadstrchar (var s: string255;var p2: integer; var ch: char);
procedure fwritestrchar (var s: string;
				  var p2: integer; ch: char; rleng: shortint);
procedure freadstrword (var s: string255;var p2: integer; var i: shortint);
{PROCEDURE FREADSTRINT (VAR S: STRING255;VAR P2,I: INTEGER);}
procedure fwritestrword (var s: string;var p2: integer; i,rleng: shortint);
{PROCEDURE FWRITESTRINT(VAR T: STRING;
			       VAR P2: INTEGER; I: INTEGER; RLENG: SHORTINT); }
procedure freadstrstr (var t: string255;var p2: integer; var s: string);
procedure fwritestrstr (var s: string; var p2: integer;
					anyvar t: string255; rleng: shortint);
procedure fwritestrpaoc (var s: string; var p2: integer;
					var a: window; aleng,rleng: shortint);
procedure freadstrpaoc (var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
procedure freadstrenum (var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
procedure fwritestrenum(var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
procedure freadstrbool (var s: string255;var p2: integer; var b: boolean);
procedure fwritestrbool(var s: string;
				 var p2: integer; b: boolean; rleng: shortint);



implement

type  booltabletype = record
		      i: shortint;
		      t,f: string[5];
		      end;
      string1 = string[1];
const booltable = booltabletype[i:2, t:'TRUE', f:'FALSE'];
      nullstring = string1[''];

const special_eft = 0;   {disallowed efts for 3rd open parameter. SFB}
      dir_eft     = 3;

procedure zapspaces(var s: string);
var i,j: shortint;
    c: char;
begin
i := 1; j := 0;
while i <= strlen(s) do
  begin
  c := s[i];
  if (c > ' ') and (c <> chr(del)) then
    begin
    j := j + 1;
    s[j] := c;
    end;
  i := i + 1;
  end;
setstrlen(s, j);
end;

function suffix(var ftitle: string): filekind;
label 1;
var tail: suffixtype;
    i,j,k: shortint;
    fk: filekind;
begin
suffix := datafile;
j := strlen(ftitle);
for fk := untypedfile to lastfkind do
 begin
 k := strlen(suffixtable^[fk]);
 if (k > 0) and (j >= k+1) then
  if ftitle[j-k] = '.' then
    begin
    setstrlen(tail, k);
    for i := 1 to k do tail[i] := ftitle[j-k+i];
    upc(tail);
    if tail = suffixtable^[fk] then
      begin
      suffix := fk;
      goto 1;
      end;
    end;
 end;
1:
end;

function unitnumber(anyvar fvid:vid):boolean;
label   1;
var
  i     : integer;
begin
  unitnumber := false;
  if strlen(fvid)>0 then
   if fvid[1]='#' then
   begin
     for i := 2 to strlen(fvid) do
       if (fvid[i]<'0') or (fvid[i]>'9') then goto 1;
     unitnumber := true;
   end;
1:
end;

procedure fixname(var title: string; kind: filekind);
var i,j: integer;
      c: char;
     ok: boolean;
begin
  zapspaces(title);
  j := strlen(title);
  if j>0 then
   begin
   c := title[j];
   if c <> ':' then
    if c = '.' then setstrlen(title,j-1)
    else
     if not unitnumber(title) then
       if suffix(title) = datafile {i.e. no suffix} then
	 if strlen(suffixtable^[kind]) > 0 then
	   if j+1+strlen(suffixtable^[kind]) <= strmax(title) then
	     title := title + '.' + suffixtable^[kind];
   end;
end;

function scantitle(fname: fid; var fvid: vid; var ftitle: fid;
		   var fsegs: integer; var fkind: filekind);
var i,j,k: integer;

  procedure volume;
  var k: integer;
  begin
  setstrlen(fvid,j-1);  for k := 1 to j-1 do fvid[k] := fname[k];
  i := j;
  end;

procedure swapvolpass;
var
  k     : integer;
  doit  : boolean;
begin
  i := strpos(':',fname);
  if i > 1 then
    if fname[i-1] = '>' then
      begin
	j := strpos('<',fname);
	if (j > 0) and (j < i) then
	  if (j <= vidleng) and ((i-j) <= (passleng + 2)) then
	    begin
	      doit := true;
	      for k := j to i-2 do
		if fname[k] = '>' then
		  doit := false;
	      if doit then
		begin
		  for k := i-1 downto j do
		    fname[k+1] := fname[k];
		  fname[j] := ':';
		end;
	    end;
      end;
end;

begin   { scantitle }
fvid:=dkvid; ftitle:=''; fsegs:=0; scantitle := false; fkind := datafile;

zapspaces(fname);

if strlen(fname)>0 then     {some kind of file name is present}
 begin
 scantitle := true;

 {if an SRM volume password is to the left of the colon, move it to the right}
 swapvolpass;

 {extract volume name}
 i := 1;
 if      fname[1]='*' then begin
			    i := 2;
			    fvid:=syvid;
			    end
 else if fname[1]='#' then
   begin
   strread(fname,2,j,k);
   if ioresult = ord(inoerror) then
     begin
       scantitle := (k<=maxunit) and (k>0);
       if j>strlen(fname) then volume
       else if fname[j]=':' then volume
       else scantitle := false;
     end
   else scantitle := false;
   end
 else
   begin
   j := strpos(':',fname);
   if (j>1) and (j <= vidleng+1) then volume;
   end;

 if i<=strlen(fname) then if fname[i]=':' then i := i + 1;

 strdelete(fname, 1, i-1);     {zap volume name}

 {get file size specifier}
 j := strpos('[',fname);
 if (j>0) and (j<strlen(fname)) then
     begin
     i := j+1;
     if fname[i]='*' then
       begin
       fsegs := -1;
       i := i + 1;
       end
     else
       begin
       strread(fname,i,i,fsegs);
       if (ioresult <> ord(inoerror)) or (fsegs<0) then
	 begin
	   i := 0;
	   fsegs := 0;
	 end;
       end;
     if (i > 0) and (i<=strlen(fname)) then
       if fname[i]=']' then strdelete(fname,j,i+1-j)
       else fsegs := 0
     else fsegs :=0;
     end;

 {all the rest is FTITLE}
 ftitle := fname;

 fkind := suffix(fname);
 ioresult := ord(inoerror);
 end;
end; {SCANTITLE}

function findvolume(var fvid: vid; verify: boolean): unitnum;
var   lunit: unitnum;   ok: boolean;
      i: integer;
      upcname: vid;
begin
findvolume := 0; ok := false;
if strlen(fvid) > 0 then
  begin
    if fvid[1] = '#' then
	 begin
	 strread(fvid, 2, i, lunit);
	 ok := (i = strlen(fvid)+1) and (lunit > 0) and (lunit <= maxunit);
	 if ok then with unitable^[lunit] do
	     begin
	     call (dam, uvid, lunit, getvolumename);
	     if strlen(uvid) > 0 then fvid := uvid;
	     end;
	 end
    else begin
	 upcname := fvid;       upc(upcname);
	 i := 0;
	 repeat
	   lunit := maxunit;
	   repeat with unitable^[lunit] do
	     begin
	     if uuppercase  and odd(i) then ok := upcname = uvid { scs 2/08/83}
				       else ok :=    fvid = uvid;
	     if (ok and verify) or (i = 2) then                  { scs 2/08/83}
	       begin
	       call (dam, uvid, lunit, getvolumename);
	       if uuppercase and odd(i) then ok := upcname = uvid{ scs 2/08/83}
					else ok :=    fvid = uvid;
	       end;
	     if not ok then lunit := lunit-1;
	     end;
	   until ok or (lunit = 0);
	   i := i + 1;
	 until ok or (i > 3);                                    { scs 2/08/83}
	 end;
  end; {strlen(FVID)>0}

if ok then findvolume := lunit;
end (*FINDVOLUME*) ;


procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);
var
  lkind         : filekind;
  segs          : integer;
  lfib          : fib;

begin   {do prefix}
  ioresult := ord(inoerror);
  if (strlen(dirname)>0) then
  with lfib do
  begin
    if scantitle(dirname,fvid,ftitle,segs,lkind) then
      begin
      funit        := findvolume(fvid,true);
      if (funit = 0) or unitnumber(fvid) then
	if findunit then ioresult := ord(inounit)
	else if strlen(ftitle)>0 then ioresult := ord(ibadtitle)
	     else begin kvid    := fvid; ioresult := ord(inoerror); end
      else
	begin
	fkind      := lkind;
	fanonymous := false;
	pathid     := -1;
	call(unitable^[funit].dam,lfib,funit,setunitprefix);
	if ioresult = ord(inoerror) then
	   begin kvid := unitable^[funit].uvid; kunit := funit; end;
	end;
      end { scantitle ok }
    else ioresult:=ord(ibadtitle);
  end;  { with }
end;

(* FILE STATE HANDLERS *)

procedure initfibfields(var f: fib);
  begin with f do
    begin
    freadmode := false; fbufvalid := false;
    freadable := false; fwriteable := false;
    flockable := false; flocked := true;
    feoln := true;      feof := true;
    fb0 := false;       fb1 := false;
    fextra2 := 8; { default tab stops }
    end;
  end;

procedure finitb (var f: fib; window: windowp; recbytes: integer);
begin
with f do
  begin initfibfields(f);
  fwindow := window;  fistextvar := recbytes = -3;
  if recbytes = -1 then
    begin fwindow := nil; frecsize := 0 end
  else if recbytes <= 0 then
    begin
    fwindow^[1] := chr(0); frecsize := 1;
    end
  else frecsize := recbytes;
  fbuffered := frecsize > 0;
  end;
end (*FINITB*) ;

procedure parsename(var f: fib; var filetitle: string);
var kind: filekind;
begin
ioresult := ord(inoerror);
with f do
    if strlen(filetitle) > fidleng then ioresult := ord(ibadtitle)
    else if not scantitle(filetitle,fvid,ftitle,fpos,kind)
	 then ioresult := ord(ibadtitle)
    else fkind := kind;
end;

procedure setfilestate(var f: fib; typ: faccess);
begin with f do if ioresult = ord(inoerror) then
  begin
  fpos := 0;                  {reset file pointer to beginning}
  fbufvalid := false;         {clear lookahead buffer}
  case typ of
    readonly:
      begin feof := false; freadmode := true; feoln := true;
      freadable := true; fwriteable := false;
      end;
    readwrite:
      begin feof := false; freadmode := false;
      freadable := true; fwriteable := true;
      end;
    writeappend:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fpos := fleof;                          {seek to end of file}
      end;
    writeonly:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fleof := 0; fmodified := true;          {zap current contents of file}
      end;
    end;
  end;
end;


{------------------------------------------------------------------------}
{                                                                        }
{    The comments in this paragraph describe the changes made to         }
{    fileopen() to effect repair of FSDdt01559 - "Pascal does not        }
{    recognize write protect on diskettes".                              }
{                                                                        }
{    The error manifested itself as follows : when attempting to write   }
{    to an unwriteable medium SPECIFIED BY UNIT NUMBER, if there         }
{    happened to be a higher numbered volume on line of THE SAME NAME,   }
{    which was writeable, that higher numbered medium could be written   }
{    to. This would not be incorrect behavior had the medium been        }
{    specified by volume name. For the case of specification by unit     }
{    number, however, correct behavior would be to inform the user that  }
{    the specified medium could not be written and return an i/o error.  }
{                                                                        }
{    In order to select a unit when attempting to open a file, fileopen  }
{    calls findvolume() to return the unit number of the volume specified. }
{    In the case the volume is specified as a unit number, findvolume    }
{    has the side effect of modifying the volume name passed in (a       }
{    number) to the volume name corresponding to that number (in the     }
{    unit table). It is the nature (and rightly so, under most circum-   }
{    stances) for fileopen to make a second try at locating a unit       }
{    number should the DAM call (indexed from the first unit number      }
{    returned from findvolume) fail for any reason. However, at the      }
{    time of this second call to findvolume, WE HAVE LOST THE ORIGINAL   }
{    VOLUME SPECIFICATION AS A UNIT NUMBER. What we have instead as a    }
{    volume specifier is the volume name corresponding to the original   }
{    numeric volume specifier. Since findvolume does a backward search   }
{    through the unit table when searching for a unit SPECIFIED BY       }
{    VOLUME NAME, if there are any other volumes on line of the same     }
{    name as our originally specified volume, at a higher unit number,   }
{    findvolume will return a unit number different than originally      }
{    specified by the user ! If the medium corresponding to this unit    }
{    number is writeable, the wrong medium may be written to !           }
{                                                                        }
{    The fix implemented here is to not allow a second attempt at        }
{    finding a unit number when the first DAM call fails in the case     }
{    that the original volume specification was by unit number.          }
{                                                                        }
{    All the added lines of code are located in fileopen() and are       }
{    commented should for any reason (HA!) the repair needs to be        }
{    backed out.                                                         }
{                                                                        }
{                                         JWH - 10/27/88                 }

procedure fileopen(var f: fib; typ, styp: faccess;
			{additional parameter for Rev. 3.2}
			{added 30-Jun-86 geli}
			is_set_feft: boolean);
label   1,2,3;
var verify: boolean;
var is_unit_num : boolean;    { <=== ADDED 10/27/88 - JWH }
begin
if ioresult = ord(inoerror) then with f do
 begin
  lockup;
  try
  if fpos > 0 then fpos := fpos*fblksize;
  if not is_set_feft then
    feft := efttable^[fkind];
  fisnew := typ=writeonly;
  freptcnt := 0; fbufchanged := false; flastpos := -1;
  fstartaddress := 0;   pathid := -1;  fnosrmtemp := true;
  verify := false;
  is_unit_num := false;  { <=== ADDED 10/27/88 - JWH }
  if (fvid[1] = '#') then  { <=== ADDED 10/27/88 - JWH }
     is_unit_num := true;  { <=== ADDED 10/27/88 - JWH }
2:funit := findvolume(fvid,verify);
  if funit = 0 then ioresult := ord(inounit);
  if ioresult = 0 then
    with unitable^[funit] do
      begin                                       (*OK...OPEN UP FILE*)
      if not fisnew then           {try to open an existing file }
	begin
	if typ = overwrite then call (dam, f, funit, overwritefile)
			   else call (dam, f, funit, openfile);
	if ioresult <> ord(inoerror) then
	  if ((ioresult<>ord(inofile)) and (not verify) and (not is_unit_num))
	       then  { <=== ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else if (typ <> readonly) and (ioresult=ord(inofile))
		{added inofile check, as the only time we should create new file
		 for open or append is if file doesn't exist. If can't access
		 file, or can't access filesystem (eg ioresult=44), then just
		 exit with ioresult.
		 Note that overwritefile can create a new file which is "strange",
		 but SRMDAM and LIFDAM do it, returning inoerror. Could cause
		 problems on SRM if file disappears after EDITOR of FILER
		 detects its existence.
		 Fixes FSDdt02098. SFB/RDQ 01/05/89}
	   then fisnew := true else goto 1
	else if typ <> readonly then
	  begin
	  if fpos > fpeof then
	    begin
	    call (dam, f, funit, stretchit);
	    if fpos > fpeof then
	      begin
	      if typ = overwrite then call (dam, f, funit, purgefile);
	      ioresult := ord(icantstretch);
	      goto 1;
	      end;
	    end;
	  if typ = overwrite then goto 3;
	  end;
	end;
      if typ = readwrite then if fistextvar then
	begin
	if not fisnew then call (dam, f, funit, closefile);
	ioresult := ord(ibadfiletype); goto 1;
	end;
      if fisnew then               {try to make a new file}
	begin
	call (dam, f, funit, createfile);
	if ioresult <> ord(inoerror) then
	  if ((not verify) and (not is_unit_num)) then  { <=== 10/27/88 }
	     { ^ ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else goto 1;
	end;
   3: fmodified := fisnew;
      end;
1:setfilestate(f,styp);
  recover begin lockdown; escape(escapecode); end;
  lockdown;
 end;
end; {FILEOPEN}

procedure fclose (var f: fib; ftype: closetype);
label 1;
var  oldio : integer;                                   {rdq 14/sep/83 }
begin
  lockup;
  try
  ioresult := ord(inoerror); oldio:=ioresult;           {rdq}
  with f do
    if freadable or fwriteable then
      begin
	if fanonymous or (ftype = purge) or (fisnew and (ftype = cnormal))
	then call (unitable^[funit].dam, f, funit, purgefile)
	else
	  begin
	  if flocked then
	    begin
	    call (am, addr(f), flush, f, 0 , 0); oldio:=ioresult;       {rdq}
	    if (ioresult <> ord(inoerror)) and
	       (ioresult <> ord(inoaccess)) then goto 1;        {rdq 14/sep/83}
	    {set logical end of file to current file position}
	    if ftype = ccrunch then if fleof <> fpos then
		 begin
		 if fpos > fpeof then
		   begin
		   call (unitable^[funit].dam, f, funit, stretchit);
		   if fpos > fpeof then
		     begin ioresult := ord(icantstretch); goto 1; end;
		   end;
		 fleof := fpos; fmodified := true;
		 end;
	    end;
	  call (unitable^[funit].dam, f, funit, closefile);
	  end;
	initfibfields(f);
      end;
      if oldio<>ord(inoerror) then ioresult:=oldio;             {rdq 14/sep/83}
1:recover begin lockdown; escape(escapecode); end;
  lockdown;
end (*FCLOSE*) ;

procedure fcloseit(var f: fib; stype: string255);
  var s: string255; k: shortint; ch: char; ok: boolean;
      ftype: closetype;
begin
with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen) else
    begin
    s := stype; k := 1;
    while k <= strlen(s) do
      begin ch := s[k];
      if ch <= ' ' then strdelete(s,k,1)
      else
	begin
	if  (ch>='a') and (ch<='z') then
	  s[k] := chr(ord(ch)+(ord('A')-ord('a')));
	k := k+1;
	end;
      end;
    ok := true;
    if (s = 'NORMAL') or (s = 'TEMP') then
      ftype := cnormal
    else if (s = 'LOCK') or (s = 'SAVE') then
      ftype := lock
    else if s = 'PURGE' then ftype := purge
    else if s = 'CRUNCH' then ftype := ccrunch
    else
      begin ioresult := ord(ibadclose); ok := false end;
    if ok then fclose(f,ftype);
    end;
end; {fcloseit}

procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);
begin
  f.fanonymous := true;
  parsename(f, name);
  f.fkind := kind;
  f.fpos := size;
  f.foptstring := addr(nullstring);
  fileopen(f,writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure fhpreset(var f: fib; typ: faccess);
begin {fhpreset}
ioresult := ord(inoerror);
with f do
  if not (freadable or fwriteable) then
     begin
     fanonymous := true;
     fvid := syvid;
     fkind := datafile;
     fpos := -1;
     foptstring := addr(nullstring);
     fileopen(f, writeonly, typ,false); {changed 30-Jun-86 geli}
     end
  else setfilestate(f,typ);
end;

(***************************************************************************)
(* This routine parses an option string input via the 3rd parameter in a   *)
(* Pascal open, reset, rewrite and append 'system' call. The option string *)
(* is splitted into a 'damoption' part and a 'typeinfo' part. The damoption*)
(* part is passed to the DAM with the fib field foptstring. The other part *)
(* gets parsed in the fs.                                                  *)
(* The return values are : FALSE if option contains no typeinfo part       *)
(*                         TRUE  if option contains typeinfo part          *)
(*                                                                         *)
(* Author: Angelika Hierath                                                *)
(*         30-Jun-86                                                       *)
(*                                                                         *)
(***************************************************************************)
function parseoption( option: string255;
		      var damoption, typeinfo: string255): boolean;

var i : integer;        {actual position in option}
    state : integer;
    done: boolean;

begin
  (* initialisation of variables *)
  parseoption := false;
  i := 1;
  done := false;
  setstrlen(damoption,0);
  setstrlen(typeinfo,0);
  state := 1;

  (* if there is an option string do *)
  if strlen(option) <> 0 then
    repeat
      case state of
      1: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,damoption,strlen(damoption)+1)
	     else
	       state := 2;
	     i := i+1;
	   end
	 else
	   done := true;
      2: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       begin
		 strmove(1,option,i,typeinfo,strlen(typeinfo)+1);
		 state := 3;
		 parseoption := true;
	       end
	     else
	       begin
		 strappend(damoption,'\');
		 state := 1;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      3: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,typeinfo,strlen(typeinfo)+1)
	     else
	       begin
		 strmove(strlen(option)-i,option,i+1,damoption,strlen(damoption)+1);
		 done := true;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      end;
    until done;              {until at end of option string}
end;

(**********************************************************************)
(* This routine parses a typeinfo string. It checks whether there is a*)
(* suffix or a file type present. The possible suffixes are according *)
(* to the ones described in the Pascal Designers Guide section File   *)
(* system. They can be in any combination of upper and lower case     *)
(* letters. The file type can be any integer number that fits into a  *)
(* shortint (-32K..32k). If the typeinfo string doesn't contain a     *)
(* valid suffix or filetype, fkind gets set to datafile.              *)
(* (\0\ and \3\ are not valid, for various good reasons. It is        *)
(* confusing to see, for example, a "directory" on HFS that has a     *)
(* WSheader, and isn't really a directory as far as the DAM is        *)
(* concerned. Ditto special files. Therefore, we don't allow these    *)
(* to be made with the third parameter. SFB)                          *)
(* Otherwise fkind gets set according to the given suffix. If there   *)
(* is a file type present the variable feft gets assigned this        *)
(* value and fkind gets set accordingly.                              *)
(*                                                                    *)
(* The return values are  FALSE: if there was no file type given      *)
(*                        TRUE : if typeinfo contained a file type    *)
(*                                                                    *)
(* Author: Angelika Hierath                                           *)
(*         10-Jun-86                                                  *)
(*                                                                    *)
(**********************************************************************)

function parse_tinfo(typeinfo: string255;
		     var fkind: filekind;var feft: shortint): boolean;

var pos: integer;
    fk: filekind;

begin
  fkind := datafile;
  parse_tinfo := false;

    strread(typeinfo,1,pos,feft);
    if ioresult = ord(inoerror) then     (* got numeric, maybe valid *)
     begin
      if (feft<>special_eft) and (feft<>dir_eft) then {not special files/dirs SFB}
       begin
	 for fk := untypedfile to lastfkind do
	   if efttable^[fk] = feft then
	     fkind := fk;
	 parse_tinfo := true;
       end  {if (feft... SFB}
      end
    else
      begin
	ioresult := ord(inoerror);
	for fk := untypedfile to lastfkind do
	begin
	  upc(typeinfo);
	  if typeinfo = suffixtable^[fk] then
	      fkind := fk;
	end;
      end;
end;

{ this routine changed for revision 3.2. It is now possible to pass   }
{ a external file type in the option string. A file gets then created }
{ with this eft no matter which suffix is there on the file name      }
{ added 30-Jun-86 geli }
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
var damoption, typeinfo: string255;
    feft_flag: boolean;
    kind: filekind;

begin
 {initialize local variables}
 setstrlen(damoption,0);
 setstrlen(typeinfo,0);
 feft_flag := false;

 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);

 {parse option string; this part is new for revision 3.2 added 30-Jun-86 geli}
 if parseoption(option, damoption,typeinfo) then
   begin
     feft_flag := parse_tinfo(typeinfo,kind,f.feft);
     f.fkind := kind;
     f.foptstring := addr(damoption);
   end
 else
   f.foptstring := addr(option);
 fileopen(f,typ,typ,feft_flag);     {changed 30-Jun-86 geli}
end;

procedure fmaketype(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure foverfile(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, overwrite, writeonly,false);       {changed 30-Jun-86 geli}
end;


{file positioning primitives}

procedure fseek(var f: fib; position: integer);
begin with f do
  if not (freadable and fwriteable and flocked) then
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not(freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked)
  else if position < 1 then ioresult := ord(ibadvalue)          { scs 2/08/83 }
  else begin
       ioresult := ord(inoerror);
      {if position < 1 then fpos := 0                            scs 1/17/83
       else}
       fpos := (position - 1) * frecsize;
       freadmode := false; fbufvalid := false;  {non read mode condition}
       end;
end;

function fposition(var f: fib): integer;
begin
with f do
  if (freadable or fwriteable) and flocked then
    begin ioresult := ord(inoerror);
    fposition := fpos div frecsize + 1 - ord(fbufvalid);
    end
  else
    begin
    if not(freadable or fwriteable) then ioresult := ord(inotopen)
    else ioresult := ord(ifileunlocked);
    fposition := 0;
    end;
end;

function fmaxpos(var f: fib): integer;
begin with f do
  if freadable and fwriteable and flocked then
       begin ioresult := ord(inoerror);
       fmaxpos := fleof div frecsize;
       end
  else begin
       fmaxpos := 0;
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not (freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked);
       end;
end;


{PASCAL I/O primitives}

function fbufferref(var f: fib): windowp;
begin
with f do
 begin
 fbufferref := fwindow;                         {primary objective}
 if freadmode and not fbufvalid and flocked then {lazy I/O condition}
   begin
   call (am, addr(f), readbytes, fwindow^, frecsize, fpos);
   if ioresult = ord(ieof) then
     begin
     feof := true;
     if not feoln then
       begin
       fwindow^[0] := ' ';
       feoln := true;                           {create 'GHOST' end of line}
       fbufvalid := true;
       ioresult := ord(inoerror);
       end
     end
   else begin fbufvalid := true; feof := false; end;
   end
 else if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not flocked then ioresult := ord(ifileunlocked)
	   else ioresult := ord(inoerror);
 end;
end;

procedure fget(var f: fib);
begin
with f do
  if freadmode and not fbufvalid then fread(f, f.fwindow^)
						{set lazy I/O condition}
  else if not (freadable and flocked) then
	  if not (freadable or fwriteable) then ioresult := ord(inotopen)
	  else if not freadable then ioresult := ord(inotreadable)
	       else ioresult := ord(ifileunlocked)
       else  begin ioresult := ord(inoerror);
	     freadmode := true;  fbufvalid := false; {set lazy I/O condition}
	     end;
end;

procedure fput (var f: fib);
begin
  fwrite(f, f.fwindow^);                        {set non read mode condition}
end;

function feof (var f: fib);
var x: windowp;
begin
ioresult := ord(inoerror);  feof := true;       {bug fix rdq 10/13/83}
if f.flocked then
  if f.freadable or f.fwriteable then
    if f.frecsize <= 0 then feof := f.fpos >= f.fleof     {untyped files}
    else if f.freadable and f.fwriteable then feof := fposition(f)>fmaxpos(f)
	 else begin
	      if not unitable^[f.funit].uisinteractive then x := fbufferref(f);
	      if ioresult = ord(ieof) then ioresult := ord(inoerror);
	      feof := f.feof;
	      end
  else ioresult := ord(inotopen) {bug fix rdq 9/12/83}
else ioresult := ord(ifileunlocked)
end;

function feoln (var f: fib);
var x: windowp;
begin
  x := fbufferref(f);
  if ioresult = ord(ieof) then ioresult := ord(inoerror);
  feoln := f.feoln;
end;

procedure fwriteln (var f: fib);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call(am, addr(f), writeeol, fbuffer, 0, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end (*FWRITELN*) ;


{sequential record I/O }

procedure fread(anyvar f: fib; anyvar buf: window);
begin with f do
if fbufvalid and flocked then
    begin ioresult := ord(inoerror);            {look ahead condition}
    if frecsize = 1 then buf[0] := fwindow^[0]  {a common case}
    else moveleft(fwindow^, buf, frecsize);
    fbufvalid := false;                         {set lazy I/O condition}
    end
else
    if not (freadable and flocked) then
	 if not (freadable or fwriteable) then ioresult := ord(inotopen)
	 else if not freadable then ioresult := ord(inotreadable)
	      else ioresult := ord(ifileunlocked)
    else begin
	 call (am, addr(f), readbytes, buf, frecsize, fpos);
	 freadmode := true; fbufvalid := false;   {set lazy I/O condition}
	 if ioresult = ord(ieof) then
	  if fistextvar and not feoln then
	    begin
	    buf[0] := ' ';
	    feoln := true;                      {'GHOST' end of line}
	    ioresult := ord(inoerror);
	    end;
	 end;
end;

procedure fwrite(anyvar f: fib;  anyvar buf: window);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call (am, addr(f), writebytes, buf, frecsize, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end;


{sequential binary I/O }

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
var i: integer;
begin with f do
  if not (freadable and flocked) then
       if not (freadable or fwriteable) then ioresult := ord(inotopen)
       else if not freadable then ioresult := ord(inotreadable)
	    else ioresult := ord(ifileunlocked)
  else begin
       call (am, addr(f), readbytes, buf, size, fpos);
       freadmode := true; fbufvalid := false;   {set lazy I/O condition}
       end;
end;

procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);
begin with f do
 if not (fwriteable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not fwriteable then ioresult := ord(inotwriteable)
	   else ioresult := ord(ifileunlocked)
 else begin
      call (am, addr(f), writebytes, buf, size, fpos);
      freadmode := false;    fbufvalid := false;    {set non read mode}
      end;
end;



{UCSD BLOCKREAD AND BLOCKWRITE FUNCTIONS}

function fblockio (var f: fib; var buf: window;
			  nblocks, rblock: integer; doread: boolean): integer;
var blockbytes, filebytes: integer;
begin with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen)
  else if not flocked then ioresult := ord(ifileunlocked)
  else
    begin
    ioresult := ord(inoerror);
    if rblock >= 0 then fpos := rblock*fblksize
		   else fpos := fpos + (-fpos) mod fblksize;
    blockbytes := nblocks*fblksize;
    if doread then
	 begin
	 filebytes := fleof - fpos;
	 if filebytes < 0 then filebytes := 0;
	 if filebytes < blockbytes then
	   begin blockbytes := filebytes;
		 nblocks := (filebytes+(fblksize-1)) div fblksize;
	   end;
	 if blockbytes > 0 then
			call (am, addr(f), readbytes,  buf, blockbytes, fpos);
	 end
    else if blockbytes > 0 then
			call (am, addr(f), writebytes, buf, blockbytes, fpos);
    if ioresult = 0 then fblockio := nblocks  else fblockio := 0;
    end;
end;


(* This routine is useful when input can be edited *)

procedure killchar (anyvar f: fib; var sinx: integer);
var c: char;
begin
c :=  fbufferref(f)^[0];
with f, unitable^[funit]  do
  if c = chr(bs) then
    begin
    if sinx > 0 then
	 begin
	 sinx := sinx - 1;                {DELETE LAST CHARACTER FROM INPUT}
	 if uisinteractive then
	   call (am, addr(f), writebytes,
			   windowp(addr(' '#8))^, 2, 0);  {CLEAR LAST CHAR }
	 end
    else if uisinteractive then
	      call (am, addr(f), writebytes,
			   windowp(addr(#28' '))^, 1, 0);  {FIXUP CURSOR}
    end
  else if c = chr(del) then
    begin
    if uisinteractive then
      begin
      sinx := sinx + 1;                         {DEL IS A PRINTABLE CHARACTER}
      while sinx > 0 do
	begin
	call (am, addr(f), writebytes,
			   windowp(addr( #8' '#8))^, 3, 0);   {ZAP OUT LINE}
	sinx := sinx - 1;
	end;
      end;
    sinx := 0;
    end
  else sinx := sinx + 1;                        {CHARACTER OK};
fget(f);                                    {ABSORB THE CHARACTER}
end;


		       (* DEVICE CONTROL INTRINSICS *)

procedure fpage (var t: text);
begin write(t, eol, clearscr);
end;

procedure foverprint(var t: text);
begin write(t, eol);
end;

procedure fgotoxy(anyvar f: fib;      x, y:  integer);
begin
  with f do
    begin
    fxpos := x;         fypos := y;
    call(am, addr(f), setcursor, f, 0, 0);
    end;
end;

procedure fgetxy (anyvar f: fib;  var x, y:  integer);
begin
  with f do
    begin
    call(am, addr(f), getcursor, f, 0, 0);
    x := fxpos;         y := fypos;
    end;
end;


			  (* TEXT FILE INTRINSICS *)

procedure freadln (var t: text);
var index: integer;
begin
index := 0;
while not eoln(t) do killchar(t, index);        {handle characters typed}
get(t);                                         {dispose of end of line}
end (*FREADLN*) ;

procedure freadchar (var t:text; var ch: char);
begin
  fread(t, ch);              {a compiler optimization is in order here! }
end (*FREADCHAR*) ;

procedure fwritechar(var t: text; ch: char; rleng: shortint);
var s: packed array[1..255] of char;  i: integer;
begin
if rleng < 1 then rleng := 1 else for i := 1 to rleng - 1 do s[i] := ' ';
s[rleng] := ch;
fwritebytes(t, s, rleng);
end;

procedure freadword (var t:text; var i: shortint);
var  n: integer;
begin
read(t,n);      if (n<-32768) or (n>32767) then escape(-8);
i:=n;
end;

procedure freadint (var t:text; var i: integer);
label 1,2,3,4;
const maxdigits = 255;
var s: string[maxdigits];
    characters, spaces, nonspaces: integer;
    c: char;
begin
characters := 0; spaces := 0;
setstrlen(s,maxdigits);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^;        if ioresult <> 0 then goto 1;              { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; characters := characters + 1;
  get(t); c := t^; if ioresult <> 0 then goto 1;
  end;
nonspaces := 0;
if (c='-') or (c='+') then
  begin
  nonspaces := 1; s[1] := c;
  characters := characters + 1;
  get(t);  c := t^; if ioresult <> 0 then goto 1;
  end;
3: while (c>='0') and (c<='9') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  characters := characters + 1;
  c := t^; if ioresult <> 0 then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, characters);
  c := t^; if ioresult <> 0 then goto 1;
  if characters <= spaces then begin spaces := characters; goto 2; end
  else begin nonspaces := characters - spaces; goto 3; end;
  end;
4: setstrlen(s,nonspaces);
strread(s, 1, characters, i);
1:
end;

procedure fwriteword(var t:text; i,rleng: shortint);
begin  fwriteint(t,i,rleng)  end;

procedure fwriteint(var t:text; i: integer; rleng: shortint);
var   s: string255; j: integer;
begin setstrlen(s,0);
strwrite(s,1,j,i:rleng);
if ioresult = ord(inoerror) then fwritebytes(t, s[1], strlen(s));
end (*FWRITEINT*) ;

procedure fwritestr(var t: text; anyvar s: string80; rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := strlen(s)
  else if rleng > strlen(s) then
    begin
    fwritechar(t,' ',rleng-strlen(s));
    rleng := strlen(s);
    end;
  fwritebytes(t, s[1], rleng);
end (*FWRITESTR*);

procedure readpacstr(var t: text; anyvar p: window;
					   var len: integer; maxlen: integer);
label 1,2;
var   sinx: integer;   c: char;
begin
len := 0;
with fibp(addr(t))^ do
if not (freadable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not freadable then ioresult := ord(inotreadable)
	   else ioresult := ord(ifileunlocked)
else
 begin
 if unitable^[funit].uisinteractive then
   begin
   sinx := 0;
   repeat
     c := t^;
     if feoln or (ioresult <> ord(inoerror)) then goto 2;
     if (c=chr(bs)) or (c=chr(del)) then  killchar(t, sinx)
     else begin get(t); p[sinx] := c; sinx := sinx + 1; end;
   until sinx >= maxlen;
   2: len := sinx;
   end
 else
   begin
   c := t^;
   if (ioresult = ord(inoerror)) and not feoln then
     begin
     get(t); len := 1;
     if maxlen > 1 then
       begin
       call(am, addr(t), readtoeol, p[0], maxlen-1, fpos);
       if ioresult = ord(inoerror) then len := len + ord(p[0]);
       end;
     p[0] := c;
     end;
   end;
 end;
1:
end;

procedure freadstr(var t:text; var s: string);
var len: integer;
begin
 readpacstr(t, s[1], len, strmax(s));
 setstrlen(s, len);
end; (*FREADSTR*)

procedure freadpaoc(var t: text; var a: window; aleng: shortint);
  var sinx: integer;
begin
  readpacstr(t, a, sinx, aleng);
  while sinx < aleng do begin a[sinx] := ' ';sinx := sinx+1; end;
end; {freadpaoc}

procedure fwritepaoc(var t: text;  var a: window; aleng,rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := aleng
  else if rleng > aleng then
    begin
    fwritechar(t,' ',rleng-aleng);
    rleng := aleng;
    end;
  fwritebytes(t, a, rleng);
end (*FWRITEPAOC*) ;

procedure fwriteenum(var t: text; i,rleng: shortint; p: vptr);
var s: string255; dummy: integer;
begin setstrlen(s,0); dummy := 1;
fwritestrenum(s,dummy,i,rleng,p);
if ioresult = ord(inoerror) then fwritebytes(t,s[1],strlen(s));
end;

procedure freadenum(var t: text; var i: shortint; p: vptr);
label 1,2,3,4;
var s: string255;
    sinx, spaces, nonspaces: integer; c: char;
begin
sinx := 0; spaces := 0;
setstrlen(s, 255);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^; if ioresult <> ord(inoerror) then goto 1;         { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
nonspaces := 0;
if ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z')) then
  begin
  nonspaces := 1; s[1] := c;
  sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
3: while ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z'))
      or ((c>='0') and (c<='9')) or (c = '_') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  sinx := sinx + 1; c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, sinx);
  c := t^; if ioresult <> ord(inoerror) then goto 1;
  if sinx <= spaces then  begin spaces := sinx; goto 2; end
  else  begin nonspaces := sinx - spaces; goto 3; end;
  end;
4: setstrlen(s, nonspaces); sinx := 1;
freadstrenum(s, sinx, i, p);
1:
end;

procedure fwritebool(var t: text; b: boolean; rleng: shortint);
var p: vptr;
begin
  p.i := addr(booltable);
  fwriteenum(t,ord(b),rleng,p);
end;

procedure freadbool(var t: text; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadenum(t,i,p);
  b := i=1;
end;


	(*  STRING I/O INTRINSICS *)

procedure freadstrchar(var s: string255; var p2: integer; var ch: char);
begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else  begin ioresult := ord(inoerror);
      ch := s[p2]; p2 := p2+1;
      end;
end;

procedure fwritestrchar(var s: string; var p2: integer;
						   ch: char; rleng: shortint);
var t: string[1];
begin setstrlen(t,1);
t[1] := ch;
if rleng < 1 then rleng := 1;
fwritestrstr(s,p2,t,rleng);
end;

procedure fwritestrint $alias 'FS_FWRITESTRINT'$
      (var t: string; var p2: integer; i: integer; rleng: shortint); external;

procedure fwritestrword(var s: string; var p2: integer; i,rleng: shortint);
begin
   fwritestrint(s,p2,i,rleng);
end;

procedure freadstrword(var s: string255;var p2: integer; var i: shortint);
var n: integer;
begin
strread(s,p2,p2,n);
if (n<-32768) or (n>32767) then escape(-8);
i := n;
end;

{procedure freadstrint(var s: string255; var p2, i: integer);
external; }

procedure fwritestrstr(var s: string;
		       var p2: integer; anyvar t: string255; rleng: shortint);
var i,tp2: integer;
begin ioresult := ord(inoerror);
if rleng <> 0 then
  begin tp2 := p2;
  if rleng < 0 then rleng := strlen(t);
  if (tp2<1) or (tp2>strlen(s)+1) then ioresult := ord(istrovfl)
  else if tp2+rleng-1>strmax(s) then
    ioresult := ord(istrovfl)
  else
    begin
    if rleng > strlen(t) then
      begin
      for i := tp2 to tp2-1+rleng-strlen(t) do s[i] := ' ';
      tp2 := tp2+rleng-strlen(t);
      end;
    if rleng > strlen(t) then rleng := strlen(t);
    moveleft(t[1],s[tp2],rleng);
    tp2 := tp2+rleng;
    if tp2-1 > strlen(s) then setstrlen(s,tp2-1);
    p2 := tp2;
    end;
  end;
end; {fwritestrstr}

procedure freadstrstr(var t: string255; var p2: integer; var s: string);
  label 1;
  var sx,k: shortint;
  begin
  sx := 0; setstrlen(s,0);
  if (p2 < 1) or (p2 > strlen(t)) then ioresult := ord(istrovfl)
  else
    begin ioresult := ord(inoerror);
    for k := p2 to strlen(t) do
      begin
      if sx >= strmax(s) then goto 1;
      sx := sx+1; s[sx] := t[k];
      end;
 1: setstrlen(s,sx); p2 := p2+sx;
    end;
  end;

procedure fwritestrpaoc(var s: string;
    var p2: integer; var a: window; aleng,rleng: shortint);
var t: string255;
begin
setstrlen(t,aleng);
moveleft(a,t[1],aleng);
fwritestrstr(s,p2,t,rleng);
end;


procedure freadstrpaoc(var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
label 1;
var i,ainx,sinx: integer;
begin sinx := p2;
if (sinx<1) or (sinx > strlen(s)) then ioresult := ord(istrovfl)
else
  begin ioresult := ord(inoerror);
  for i := 0 to aleng-1 do a[i] := ' ';
  for ainx := 0 to aleng-1 do
    begin
    if sinx > strlen(s) then goto 1;
    a[ainx] := s[sinx];
    sinx := sinx+1;
    end;
  end;
1: if ioresult = ord(inoerror) then p2 := sinx;
end;

procedure freadstrenum(var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
label 1;
const idlength = 80;
var t: string[idlength];
    q, j, tinx: integer; c: char;
    done: boolean;

begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else
  begin
  q := p2;
  while s[q] = ' ' do
    begin
    q := q + 1;
    if q > strlen(s) then begin ioresult := ord(istrovfl); goto 1; end;
    end;
  c := s[q];
  if ((c < 'A') or (c > 'Z')) and ((c < 'a') or (c > 'z')) then
	      begin ioresult := ord(ibadformat); goto 1; end;
  ioresult := ord(inoerror);
  tinx := 0; setstrlen(t, idlength);
  done := false;
  repeat
    tinx := tinx+1;
    t[tinx] := c;
    q := q + 1;
    if (q > strlen(s)) or (tinx = idlength) then done := true
    else begin c := s[q];
	 done := not (((c>='A') and (c<='Z')) or ((c>='a') and (c<='z'))
		   or ((c>='0') and (c<='9')) or (c = '_'));
	 end;
  until done;

  setstrlen(t, tinx); upc(t);
  j := p.i^-1; p.j := p.j+ sizeof(shortint);
  while p.s^<>t do
    begin
    j := j-1;
    if j < 0 then begin ioresult := ord(ibadformat); goto 1; end;
    p.j := p.j + strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  i := j; p2 := q;
  end;
1:
end; {freadenum}


procedure fwritestrenum (var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
var k: shortint;
begin
if (i<0) or (i>=p.i^) then escape(-8)
else
  begin ioresult := ord(inoerror);
  k := p.i^-1;  {index of 1st entry}
  p.j := p.j+2;
  while k>i do
    begin k := k-1;
    p.j := p.j+strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  fwritestrstr(s,p2,p.s^,rleng);
  end;
end; {fwritestrenum}

procedure fwritestrbool (var s: string;
				 var p2: integer; b: boolean; rleng: shortint);
var p: vptr;
begin
p.i := addr(booltable);
fwritestrenum(s,p2,ord(b),rleng,p);
end;

procedure freadstrbool(var s: string255; var p2: integer; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadstrenum(s,p2,i,p);
  b := i=1;
end;

procedure fstripname(s : fid; var pvname,ppath,pfname : string);
var
  tempfib : fib;
  lkind   : filekind;
  segs    : integer;
begin
  with tempfib do
  begin
    if scantitle(s,fvid,ftitle,segs,lkind) then
    begin
      funit := findvolume(fvid,true);
      if funit=0 then ioresult := ord(inounit)
      else
      begin
	call(unitable^[funit].dam,tempfib,funit,stripname);
	if ioresult=ord(inoerror) then
	begin
	  pvname := fvid;
	  ppath  := ftitle;
	  pfname := ftid;
	end;
      end;
    end
    else ioresult := ord(ibadtitle);
  end; { with }
end;

end  {file support}


@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 10:27:27 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 1624
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 1624
{modcal, code off,  search 'f'}

module fs;    {file support}

import sysglobals, asm, misc;

export

type
     closetype = (cnormal, lock, purge, ccrunch);
     faccess = (readonly,writeonly,readwrite,writeappend,overwrite);
     vptr = record case integer of
	      0: (j: integer);
	      1: (i: ^shortint);
	      2: (s: ^string80);
	      end;


procedure fstripname(s : fid; var pvname,ppath,pfname : string);
procedure fixname(var title: string; kind: filekind);
procedure zapspaces(var s: string);
function suffix(var ftitle: string): filekind;
function scantitle (fname: fid; var fvid: vid; var ftitle: fid;
			    var fsegs: integer; var fkind: filekind): boolean;
function findvolume (var fvid: vid; verify: boolean): unitnum;
procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);

procedure finitb (var f: fib; window: windowp; recbytes: integer);
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
procedure fhpreset(var f: fib; typ: faccess);
procedure fcloseit(var f: fib; stype: string255);
procedure fclose (var f: fib; ftype: closetype);
procedure fmaketype(anyvar f:fib; var title, option, typestring: string);
procedure foverfile(anyvar f:fib; var title, option, typestring: string);
procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);

procedure fseek(var f: fib; position: integer);
function fposition(var f: fib): integer;
function fmaxpos(var f: fib): integer;

function fbufferref(var f: fib): windowp;
procedure fget (var f: fib);
procedure fput (var f: fib);
function feof (var f: fib): boolean;
function feoln (var f: fib): boolean;
procedure fwriteln (var f: fib);

procedure fread(anyvar f: fib; anyvar buf: window);
procedure fwrite(anyvar f: fib;  anyvar buf: window);

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);

function fblockio (var f: fib; var buf: window;
			   nblocks,rblock: integer; doread: boolean): integer;


procedure killchar (anyvar f: fib; var sinx: integer);

procedure fpage (var t: text);
procedure foverprint(var t: text);
procedure fgotoxy(anyvar f: fib;      x, y:  integer);
procedure fgetxy (anyvar f: fib;  var x, y:  integer);

procedure freadln (var t:text);
procedure fwritechar (var t: text; ch: char; rleng: shortint);
procedure freadchar (var t:text; var ch: char);
procedure freadword (var t:text; var i: shortint);
procedure freadint (var t:text; var i: integer);
procedure fwriteword (var t:text;i,rleng: shortint);
procedure fwriteint (var t:text;i: integer; rleng: shortint);
procedure fwritestr (var t:text;anyvar s: string80; rleng: shortint);
procedure freadstr (var t:text; var s: string);
procedure fwritepaoc (var t: text; var a: window; aleng,rleng: shortint);
procedure freadpaoc (var t: text; var a: window; aleng: shortint);
procedure freadenum (var t: text; var i: shortint; p: vptr);
procedure fwriteenum(var t: text; i: shortint; rleng: shortint; p: vptr);
procedure freadbool (var t: text; var b: boolean);
procedure fwritebool(var t: text; b: boolean; rleng: shortint);


procedure freadstrchar (var s: string255;var p2: integer; var ch: char);
procedure fwritestrchar (var s: string;
				  var p2: integer; ch: char; rleng: shortint);
procedure freadstrword (var s: string255;var p2: integer; var i: shortint);
{PROCEDURE FREADSTRINT (VAR S: STRING255;VAR P2,I: INTEGER);}
procedure fwritestrword (var s: string;var p2: integer; i,rleng: shortint);
{PROCEDURE FWRITESTRINT(VAR T: STRING;
			       VAR P2: INTEGER; I: INTEGER; RLENG: SHORTINT); }
procedure freadstrstr (var t: string255;var p2: integer; var s: string);
procedure fwritestrstr (var s: string; var p2: integer;
					anyvar t: string255; rleng: shortint);
procedure fwritestrpaoc (var s: string; var p2: integer;
					var a: window; aleng,rleng: shortint);
procedure freadstrpaoc (var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
procedure freadstrenum (var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
procedure fwritestrenum(var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
procedure freadstrbool (var s: string255;var p2: integer; var b: boolean);
procedure fwritestrbool(var s: string;
				 var p2: integer; b: boolean; rleng: shortint);



implement

type  booltabletype = record
		      i: shortint;
		      t,f: string[5];
		      end;
      string1 = string[1];
const booltable = booltabletype[i:2, t:'TRUE', f:'FALSE'];
      nullstring = string1[''];

const special_eft = 0;   {disallowed efts for 3rd open parameter. SFB}
      dir_eft     = 3;

procedure zapspaces(var s: string);
var i,j: shortint;
    c: char;
begin
i := 1; j := 0;
while i <= strlen(s) do
  begin
  c := s[i];
  if (c > ' ') and (c <> chr(del)) then
    begin
    j := j + 1;
    s[j] := c;
    end;
  i := i + 1;
  end;
setstrlen(s, j);
end;

function suffix(var ftitle: string): filekind;
label 1;
var tail: suffixtype;
    i,j,k: shortint;
    fk: filekind;
begin
suffix := datafile;
j := strlen(ftitle);
for fk := untypedfile to lastfkind do
 begin
 k := strlen(suffixtable^[fk]);
 if (k > 0) and (j >= k+1) then
  if ftitle[j-k] = '.' then
    begin
    setstrlen(tail, k);
    for i := 1 to k do tail[i] := ftitle[j-k+i];
    upc(tail);
    if tail = suffixtable^[fk] then
      begin
      suffix := fk;
      goto 1;
      end;
    end;
 end;
1:
end;

function unitnumber(anyvar fvid:vid):boolean;
label   1;
var
  i     : integer;
begin
  unitnumber := false;
  if strlen(fvid)>0 then
   if fvid[1]='#' then
   begin
     for i := 2 to strlen(fvid) do
       if (fvid[i]<'0') or (fvid[i]>'9') then goto 1;
     unitnumber := true;
   end;
1:
end;

procedure fixname(var title: string; kind: filekind);
var i,j: integer;
      c: char;
     ok: boolean;
begin
  zapspaces(title);
  j := strlen(title);
  if j>0 then
   begin
   c := title[j];
   if c <> ':' then
    if c = '.' then setstrlen(title,j-1)
    else
     if not unitnumber(title) then
       if suffix(title) = datafile {i.e. no suffix} then
	 if strlen(suffixtable^[kind]) > 0 then
	   if j+1+strlen(suffixtable^[kind]) <= strmax(title) then
	     title := title + '.' + suffixtable^[kind];
   end;
end;

function scantitle(fname: fid; var fvid: vid; var ftitle: fid;
		   var fsegs: integer; var fkind: filekind);
var i,j,k: integer;

  procedure volume;
  var k: integer;
  begin
  setstrlen(fvid,j-1);  for k := 1 to j-1 do fvid[k] := fname[k];
  i := j;
  end;

procedure swapvolpass;
var
  k     : integer;
  doit  : boolean;
begin
  i := strpos(':',fname);
  if i > 1 then
    if fname[i-1] = '>' then
      begin
	j := strpos('<',fname);
	if (j > 0) and (j < i) then
	  if (j <= vidleng) and ((i-j) <= (passleng + 2)) then
	    begin
	      doit := true;
	      for k := j to i-2 do
		if fname[k] = '>' then
		  doit := false;
	      if doit then
		begin
		  for k := i-1 downto j do
		    fname[k+1] := fname[k];
		  fname[j] := ':';
		end;
	    end;
      end;
end;

begin   { scantitle }
fvid:=dkvid; ftitle:=''; fsegs:=0; scantitle := false; fkind := datafile;

zapspaces(fname);

if strlen(fname)>0 then     {some kind of file name is present}
 begin
 scantitle := true;

 {if an SRM volume password is to the left of the colon, move it to the right}
 swapvolpass;

 {extract volume name}
 i := 1;
 if      fname[1]='*' then begin
			    i := 2;
			    fvid:=syvid;
			    end
 else if fname[1]='#' then
   begin
   strread(fname,2,j,k);
   if ioresult = ord(inoerror) then
     begin
       scantitle := (k<=maxunit) and (k>0);
       if j>strlen(fname) then volume
       else if fname[j]=':' then volume
       else scantitle := false;
     end
   else scantitle := false;
   end
 else
   begin
   j := strpos(':',fname);
   if (j>1) and (j <= vidleng+1) then volume;
   end;

 if i<=strlen(fname) then if fname[i]=':' then i := i + 1;

 strdelete(fname, 1, i-1);     {zap volume name}

 {get file size specifier}
 j := strpos('[',fname);
 if (j>0) and (j<strlen(fname)) then
     begin
     i := j+1;
     if fname[i]='*' then
       begin
       fsegs := -1;
       i := i + 1;
       end
     else
       begin
       strread(fname,i,i,fsegs);
       if (ioresult <> ord(inoerror)) or (fsegs<0) then
	 begin
	   i := 0;
	   fsegs := 0;
	 end;
       end;
     if (i > 0) and (i<=strlen(fname)) then
       if fname[i]=']' then strdelete(fname,j,i+1-j)
       else fsegs := 0
     else fsegs :=0;
     end;

 {all the rest is FTITLE}
 ftitle := fname;

 fkind := suffix(fname);
 ioresult := ord(inoerror);
 end;
end; {SCANTITLE}

function findvolume(var fvid: vid; verify: boolean): unitnum;
var   lunit: unitnum;   ok: boolean;
      i: integer;
      upcname: vid;
begin
findvolume := 0; ok := false;
if strlen(fvid) > 0 then
  begin
    if fvid[1] = '#' then
	 begin
	 strread(fvid, 2, i, lunit);
	 ok := (i = strlen(fvid)+1) and (lunit > 0) and (lunit <= maxunit);
	 if ok then with unitable^[lunit] do
	     begin
	     call (dam, uvid, lunit, getvolumename);
	     if strlen(uvid) > 0 then fvid := uvid;
	     end;
	 end
    else begin
	 upcname := fvid;       upc(upcname);
	 i := 0;
	 repeat
	   lunit := maxunit;
	   repeat with unitable^[lunit] do
	     begin
	     if uuppercase  and odd(i) then ok := upcname = uvid { scs 2/08/83}
				       else ok :=    fvid = uvid;
	     if (ok and verify) or (i = 2) then                  { scs 2/08/83}
	       begin
	       call (dam, uvid, lunit, getvolumename);
	       if uuppercase and odd(i) then ok := upcname = uvid{ scs 2/08/83}
					else ok :=    fvid = uvid;
	       end;
	     if not ok then lunit := lunit-1;
	     end;
	   until ok or (lunit = 0);
	   i := i + 1;
	 until ok or (i > 3);                                    { scs 2/08/83}
	 end;
  end; {strlen(FVID)>0}

if ok then findvolume := lunit;
end (*FINDVOLUME*) ;


procedure doprefix(var dirname:fid; var kvid:vid; var kunit:integer;
							     findunit:boolean);
var
  lkind         : filekind;
  segs          : integer;
  lfib          : fib;

begin   {do prefix}
  ioresult := ord(inoerror);
  if (strlen(dirname)>0) then
  with lfib do
  begin
    if scantitle(dirname,fvid,ftitle,segs,lkind) then
      begin
      funit        := findvolume(fvid,true);
      if (funit = 0) or unitnumber(fvid) then
	if findunit then ioresult := ord(inounit)
	else if strlen(ftitle)>0 then ioresult := ord(ibadtitle)
	     else begin kvid    := fvid; ioresult := ord(inoerror); end
      else
	begin
	fkind      := lkind;
	fanonymous := false;
	pathid     := -1;
	call(unitable^[funit].dam,lfib,funit,setunitprefix);
	if ioresult = ord(inoerror) then
	   begin kvid := unitable^[funit].uvid; kunit := funit; end;
	end;
      end { scantitle ok }
    else ioresult:=ord(ibadtitle);
  end;  { with }
end;

(* FILE STATE HANDLERS *)

procedure initfibfields(var f: fib);
  begin with f do
    begin
    freadmode := false; fbufvalid := false;
    freadable := false; fwriteable := false;
    flockable := false; flocked := true;
    feoln := true;      feof := true;
    fb0 := false;       fb1 := false;
    fextra2 := 8; { default tab stops }
    end;
  end;

procedure finitb (var f: fib; window: windowp; recbytes: integer);
begin
with f do
  begin initfibfields(f);
  fwindow := window;  fistextvar := recbytes = -3;
  if recbytes = -1 then
    begin fwindow := nil; frecsize := 0 end
  else if recbytes <= 0 then
    begin
    fwindow^[1] := chr(0); frecsize := 1;
    end
  else frecsize := recbytes;
  fbuffered := frecsize > 0;
  end;
end (*FINITB*) ;

procedure parsename(var f: fib; var filetitle: string);
var kind: filekind;
begin
ioresult := ord(inoerror);
with f do
    if strlen(filetitle) > fidleng then ioresult := ord(ibadtitle)
    else if not scantitle(filetitle,fvid,ftitle,fpos,kind)
	 then ioresult := ord(ibadtitle)
    else fkind := kind;
end;

procedure setfilestate(var f: fib; typ: faccess);
begin with f do if ioresult = ord(inoerror) then
  begin
  fpos := 0;                  {reset file pointer to beginning}
  fbufvalid := false;         {clear lookahead buffer}
  case typ of
    readonly:
      begin feof := false; freadmode := true; feoln := true;
      freadable := true; fwriteable := false;
      end;
    readwrite:
      begin feof := false; freadmode := false;
      freadable := true; fwriteable := true;
      end;
    writeappend:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fpos := fleof;                          {seek to end of file}
      end;
    writeonly:
      begin feof := true; freadmode := false;
      freadable := false; fwriteable := true;
      fleof := 0; fmodified := true;          {zap current contents of file}
      end;
    end;
  end;
end;


{------------------------------------------------------------------------}
{                                                                        }
{    The comments in this paragraph describe the changes made to         }
{    fileopen() to effect repair of FSDdt01559 - "Pascal does not        }
{    recognize write protect on diskettes".                              }
{                                                                        }
{    The error manifested itself as follows : when attempting to write   }
{    to an unwriteable medium SPECIFIED BY UNIT NUMBER, if there         }
{    happened to be a higher numbered volume on line of THE SAME NAME,   }
{    which was writeable, that higher numbered medium could be written   }
{    to. This would not be incorrect behavior had the medium been        }
{    specified by volume name. For the case of specification by unit     }
{    number, however, correct behavior would be to inform the user that  }
{    the specified medium could not be written and return an i/o error.  }
{                                                                        }
{    In order to select a unit when attempting to open a file, fileopen  }
{    calls findvolume() to return the unit number of the volume specified. }
{    In the case the volume is specified as a unit number, findvolume    }
{    has the side effect of modifying the volume name passed in (a       }
{    number) to the volume name corresponding to that number (in the     }
{    unit table). It is the nature (and rightly so, under most circum-   }
{    stances) for fileopen to make a second try at locating a unit       }
{    number should the DAM call (indexed from the first unit number      }
{    returned from findvolume) fail for any reason. However, at the      }
{    time of this second call to findvolume, WE HAVE LOST THE ORIGINAL   }
{    VOLUME SPECIFICATION AS A UNIT NUMBER. What we have instead as a    }
{    volume specifier is the volume name corresponding to the original   }
{    numeric volume specifier. Since findvolume does a backward search   }
{    through the unit table when searching for a unit SPECIFIED BY       }
{    VOLUME NAME, if there are any other volumes on line of the same     }
{    name as our originally specified volume, at a higher unit number,   }
{    findvolume will return a unit number different than originally      }
{    specified by the user ! If the medium corresponding to this unit    }
{    number is writeable, the wrong medium may be written to !           }
{                                                                        }
{    The fix implemented here is to not allow a second attempt at        }
{    finding a unit number when the first DAM call fails in the case     }
{    that the original volume specification was by unit number.          }
{                                                                        }
{    All the added lines of code are located in fileopen() and are       }
{    commented should for any reason (HA!) the repair needs to be        }
{    backed out.                                                         }
{                                                                        }
{                                         JWH - 10/27/88                 }

procedure fileopen(var f: fib; typ, styp: faccess;
			{additional parameter for Rev. 3.2}
			{added 30-Jun-86 geli}
			is_set_feft: boolean);
label   1,2,3;
var verify: boolean;
var is_unit_num : boolean;    { <=== ADDED 10/27/88 - JWH }
begin
if ioresult = ord(inoerror) then with f do
 begin
  lockup;
  try
  if fpos > 0 then fpos := fpos*fblksize;
  if not is_set_feft then
    feft := efttable^[fkind];
  fisnew := typ=writeonly;
  freptcnt := 0; fbufchanged := false; flastpos := -1;
  fstartaddress := 0;   pathid := -1;  fnosrmtemp := true;
  verify := false;
  is_unit_num := false;  { <=== ADDED 10/27/88 - JWH }
  if (fvid[1] = '#') then  { <=== ADDED 10/27/88 - JWH }
     is_unit_num := true;  { <=== ADDED 10/27/88 - JWH }
2:funit := findvolume(fvid,verify);
  if funit = 0 then ioresult := ord(inounit);
  if ioresult = 0 then
    with unitable^[funit] do
      begin                                       (*OK...OPEN UP FILE*)
      if not fisnew then           {try to open an existing file }
	begin
	if typ = overwrite then call (dam, f, funit, overwritefile)
			   else call (dam, f, funit, openfile);
	if ioresult <> ord(inoerror) then
	  if ((ioresult<>ord(inofile)) and (not verify) and (not is_unit_num))
	       then  { <=== ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else if (typ <> readonly) and (ioresult=ord(inofile))
		{added inofile check, as the only time we should create new file
		 for open or append is if file doesn't exist. If can't access
		 file, or can't access filesystem (eg ioresult=44), then just
		 exit with ioresult.
		 Note that overwritefile can create a new file which is "strange",
		 but SRMDAM and LIFDAM do it, returning inoerror. Could cause
		 problems on SRM if file disappears after EDITOR of FILER
		 detects its existence.
		 Fixes FSDdt02098. SFB/RDQ 01/05/89}
	   then fisnew := true else goto 1
	else if typ <> readonly then
	  begin
	  if fpos > fpeof then
	    begin
	    call (dam, f, funit, stretchit);
	    if fpos > fpeof then
	      begin
	      if typ = overwrite then call (dam, f, funit, purgefile);
	      ioresult := ord(icantstretch);
	      goto 1;
	      end;
	    end;
	  if typ = overwrite then goto 3;
	  end;
	end;
      if typ = readwrite then if fistextvar then
	begin
	if not fisnew then call (dam, f, funit, closefile);
	ioresult := ord(ibadfiletype); goto 1;
	end;
      if fisnew then               {try to make a new file}
	begin
	call (dam, f, funit, createfile);
	if ioresult <> ord(inoerror) then
	  if ((not verify) and (not is_unit_num)) then  { <=== 10/27/88 }
	     { ^ ADDED not is_unit_num 10/27/88 - JWH }
		  begin verify := true; goto 2; end
	  else goto 1;
	end;
   3: fmodified := fisnew;
      end;
1:setfilestate(f,styp);
  recover begin lockdown; escape(escapecode); end;
  lockdown;
 end;
end; {FILEOPEN}

procedure fclose (var f: fib; ftype: closetype);
label 1;
var  oldio : integer;                                   {rdq 14/sep/83 }
begin
  lockup;
  try
  ioresult := ord(inoerror); oldio:=ioresult;           {rdq}
  with f do
    if freadable or fwriteable then
      begin
	if fanonymous or (ftype = purge) or (fisnew and (ftype = cnormal))
	then call (unitable^[funit].dam, f, funit, purgefile)
	else
	  begin
	  if flocked then
	    begin
	    call (am, addr(f), flush, f, 0 , 0); oldio:=ioresult;       {rdq}
	    if (ioresult <> ord(inoerror)) and
	       (ioresult <> ord(inoaccess)) then goto 1;        {rdq 14/sep/83}
	    {set logical end of file to current file position}
	    if ftype = ccrunch then if fleof <> fpos then
		 begin
		 if fpos > fpeof then
		   begin
		   call (unitable^[funit].dam, f, funit, stretchit);
		   if fpos > fpeof then
		     begin ioresult := ord(icantstretch); goto 1; end;
		   end;
		 fleof := fpos; fmodified := true;
		 end;
	    end;
	  call (unitable^[funit].dam, f, funit, closefile);
	  end;
	initfibfields(f);
      end;
      if oldio<>ord(inoerror) then ioresult:=oldio;             {rdq 14/sep/83}
1:recover begin lockdown; escape(escapecode); end;
  lockdown;
end (*FCLOSE*) ;

procedure fcloseit(var f: fib; stype: string255);
  var s: string255; k: shortint; ch: char; ok: boolean;
      ftype: closetype;
begin
with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen) else
    begin
    s := stype; k := 1;
    while k <= strlen(s) do
      begin ch := s[k];
      if ch <= ' ' then strdelete(s,k,1)
      else
	begin
	if  (ch>='a') and (ch<='z') then
	  s[k] := chr(ord(ch)+(ord('A')-ord('a')));
	k := k+1;
	end;
      end;
    ok := true;
    if (s = 'NORMAL') or (s = 'TEMP') then
      ftype := cnormal
    else if (s = 'LOCK') or (s = 'SAVE') then
      ftype := lock
    else if s = 'PURGE' then ftype := purge
    else if s = 'CRUNCH' then ftype := ccrunch
    else
      begin ioresult := ord(ibadclose); ok := false end;
    if ok then fclose(f,ftype);
    end;
end; {fcloseit}

procedure fanonfile(anyvar f:fib; var name:string; kind:filekind;size:integer);
begin
  f.fanonymous := true;
  parsename(f, name);
  f.fkind := kind;
  f.fpos := size;
  f.foptstring := addr(nullstring);
  fileopen(f,writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure fhpreset(var f: fib; typ: faccess);
begin {fhpreset}
ioresult := ord(inoerror);
with f do
  if not (freadable or fwriteable) then
     begin
     fanonymous := true;
     fvid := syvid;
     fkind := datafile;
     fpos := -1;
     foptstring := addr(nullstring);
     fileopen(f, writeonly, typ,false); {changed 30-Jun-86 geli}
     end
  else setfilestate(f,typ);
end;

(***************************************************************************)
(* This routine parses an option string input via the 3rd parameter in a   *)
(* Pascal open, reset, rewrite and append 'system' call. The option string *)
(* is splitted into a 'damoption' part and a 'typeinfo' part. The damoption*)
(* part is passed to the DAM with the fib field foptstring. The other part *)
(* gets parsed in the fs.                                                  *)
(* The return values are : FALSE if option contains no typeinfo part       *)
(*                         TRUE  if option contains typeinfo part          *)
(*                                                                         *)
(* Author: Angelika Hierath                                                *)
(*         30-Jun-86                                                       *)
(*                                                                         *)
(***************************************************************************)
function parseoption( option: string255;
		      var damoption, typeinfo: string255): boolean;

var i : integer;        {actual position in option}
    state : integer;
    done: boolean;

begin
  (* initialisation of variables *)
  parseoption := false;
  i := 1;
  done := false;
  setstrlen(damoption,0);
  setstrlen(typeinfo,0);
  state := 1;

  (* if there is an option string do *)
  if strlen(option) <> 0 then
    repeat
      case state of
      1: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,damoption,strlen(damoption)+1)
	     else
	       state := 2;
	     i := i+1;
	   end
	 else
	   done := true;
      2: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       begin
		 strmove(1,option,i,typeinfo,strlen(typeinfo)+1);
		 state := 3;
		 parseoption := true;
	       end
	     else
	       begin
		 strappend(damoption,'\');
		 state := 1;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      3: if strlen(option) >= i then
	   begin
	     if option[i] <> '\' then
	       strmove(1,option,i,typeinfo,strlen(typeinfo)+1)
	     else
	       begin
		 strmove(strlen(option)-i,option,i+1,damoption,strlen(damoption)+1);
		 done := true;
	       end;
	     i := i+1;
	   end
	 else
	   done := true;
      end;
    until done;              {until at end of option string}
end;

(**********************************************************************)
(* This routine parses a typeinfo string. It checks whether there is a*)
(* suffix or a file type present. The possible suffixes are according *)
(* to the ones described in the Pascal Designers Guide section File   *)
(* system. They can be in any combination of upper and lower case     *)
(* letters. The file type can be any integer number that fits into a  *)
(* shortint (-32K..32k). If the typeinfo string doesn't contain a     *)
(* valid suffix or filetype, fkind gets set to datafile.              *)
(* (\0\ and \3\ are not valid, for various good reasons. It is        *)
(* confusing to see, for example, a "directory" on HFS that has a     *)
(* WSheader, and isn't really a directory as far as the DAM is        *)
(* concerned. Ditto special files. Therefore, we don't allow these    *)
(* to be made with the third parameter. SFB)                          *)
(* Otherwise fkind gets set according to the given suffix. If there   *)
(* is a file type present the variable feft gets assigned this        *)
(* value and fkind gets set accordingly.                              *)
(*                                                                    *)
(* The return values are  FALSE: if there was no file type given      *)
(*                        TRUE : if typeinfo contained a file type    *)
(*                                                                    *)
(* Author: Angelika Hierath                                           *)
(*         10-Jun-86                                                  *)
(*                                                                    *)
(**********************************************************************)

function parse_tinfo(typeinfo: string255;
		     var fkind: filekind;var feft: shortint): boolean;

var pos: integer;
    fk: filekind;

begin
  fkind := datafile;
  parse_tinfo := false;

    strread(typeinfo,1,pos,feft);
    if ioresult = ord(inoerror) then     (* got numeric, maybe valid *)
     begin
      if (feft<>special_eft) and (feft<>dir_eft) then {not special files/dirs SFB}
       begin
	 for fk := untypedfile to lastfkind do
	   if efttable^[fk] = feft then
	     fkind := fk;
	 parse_tinfo := true;
       end  {if (feft... SFB}
      end
    else
      begin
	ioresult := ord(inoerror);
	for fk := untypedfile to lastfkind do
	begin
	  upc(typeinfo);
	  if typeinfo = suffixtable^[fk] then
	      fkind := fk;
	end;
      end;
end;

{ this routine changed for revision 3.2. It is now possible to pass   }
{ a external file type in the option string. A file gets then created }
{ with this eft no matter which suffix is there on the file name      }
{ added 30-Jun-86 geli }
procedure fhpopen(var f: fib; typ: faccess; var title, option: string255);
var damoption, typeinfo: string255;
    feft_flag: boolean;
    kind: filekind;

begin
 {initialize local variables}
 setstrlen(damoption,0);
 setstrlen(typeinfo,0);
 feft_flag := false;

 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);

 {parse option string; this part is new for revision 3.2 added 30-Jun-86 geli}
 if parseoption(option, damoption,typeinfo) then
   begin
     feft_flag := parse_tinfo(typeinfo,kind,f.feft);
     f.fkind := kind;
     f.foptstring := addr(damoption);
   end
 else
   f.foptstring := addr(option);
 fileopen(f,typ,typ,feft_flag);     {changed 30-Jun-86 geli}
end;

procedure fmaketype(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, writeonly,writeonly,false);        {changed 30-Jun-86 geli}
end;

procedure foverfile(anyvar f: fib; var title, option, typestring: string);
begin
 fclose(f, cnormal);
 f.fanonymous := false;
 parsename(f,title);
 f.fkind := suffix(typestring);
 f.foptstring := addr(option);
 fileopen(f, overwrite, writeonly,false);       {changed 30-Jun-86 geli}
end;


{file positioning primitives}

procedure fseek(var f: fib; position: integer);
begin with f do
  if not (freadable and fwriteable and flocked) then
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not(freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked)
  else if position < 1 then ioresult := ord(ibadvalue)          { scs 2/08/83 }
  else begin
       ioresult := ord(inoerror);
      {if position < 1 then fpos := 0                            scs 1/17/83
       else}
       fpos := (position - 1) * frecsize;
       freadmode := false; fbufvalid := false;  {non read mode condition}
       end;
end;

function fposition(var f: fib): integer;
begin
with f do
  if (freadable or fwriteable) and flocked then
    begin ioresult := ord(inoerror);
    fposition := fpos div frecsize + 1 - ord(fbufvalid);
    end
  else
    begin
    if not(freadable or fwriteable) then ioresult := ord(inotopen)
    else ioresult := ord(ifileunlocked);
    fposition := 0;
    end;
end;

function fmaxpos(var f: fib): integer;
begin with f do
  if freadable and fwriteable and flocked then
       begin ioresult := ord(inoerror);
       fmaxpos := fleof div frecsize;
       end
  else begin
       fmaxpos := 0;
       if not(freadable or fwriteable) then ioresult := ord(inotopen)
       else if not (freadable and fwriteable) then ioresult := ord(inotdirect)
	    else ioresult := ord(ifileunlocked);
       end;
end;


{PASCAL I/O primitives}

function fbufferref(var f: fib): windowp;
begin
with f do
 begin
 fbufferref := fwindow;                         {primary objective}
 if freadmode and not fbufvalid and flocked then {lazy I/O condition}
   begin
   call (am, addr(f), readbytes, fwindow^, frecsize, fpos);
   if ioresult = ord(ieof) then
     begin
     feof := true;
     if not feoln then
       begin
       fwindow^[0] := ' ';
       feoln := true;                           {create 'GHOST' end of line}
       fbufvalid := true;
       ioresult := ord(inoerror);
       end
     end
   else begin fbufvalid := true; feof := false; end;
   end
 else if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not flocked then ioresult := ord(ifileunlocked)
	   else ioresult := ord(inoerror);
 end;
end;

procedure fget(var f: fib);
begin
with f do
  if freadmode and not fbufvalid then fread(f, f.fwindow^)
						{set lazy I/O condition}
  else if not (freadable and flocked) then
	  if not (freadable or fwriteable) then ioresult := ord(inotopen)
	  else if not freadable then ioresult := ord(inotreadable)
	       else ioresult := ord(ifileunlocked)
       else  begin ioresult := ord(inoerror);
	     freadmode := true;  fbufvalid := false; {set lazy I/O condition}
	     end;
end;

procedure fput (var f: fib);
begin
  fwrite(f, f.fwindow^);                        {set non read mode condition}
end;

function feof (var f: fib);
var x: windowp;
begin
ioresult := ord(inoerror);  feof := true;       {bug fix rdq 10/13/83}
if f.flocked then
  if f.freadable or f.fwriteable then
    if f.frecsize <= 0 then feof := f.fpos >= f.fleof     {untyped files}
    else if f.freadable and f.fwriteable then feof := fposition(f)>fmaxpos(f)
	 else begin
	      if not unitable^[f.funit].uisinteractive then x := fbufferref(f);
	      if ioresult = ord(ieof) then ioresult := ord(inoerror);
	      feof := f.feof;
	      end
  else ioresult := ord(inotopen) {bug fix rdq 9/12/83}
else ioresult := ord(ifileunlocked)
end;

function feoln (var f: fib);
var x: windowp;
begin
  x := fbufferref(f);
  if ioresult = ord(ieof) then ioresult := ord(inoerror);
  feoln := f.feoln;
end;

procedure fwriteln (var f: fib);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call(am, addr(f), writeeol, fbuffer, 0, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end (*FWRITELN*) ;


{sequential record I/O }

procedure fread(anyvar f: fib; anyvar buf: window);
begin with f do
if fbufvalid and flocked then
    begin ioresult := ord(inoerror);            {look ahead condition}
    if frecsize = 1 then buf[0] := fwindow^[0]  {a common case}
    else moveleft(fwindow^, buf, frecsize);
    fbufvalid := false;                         {set lazy I/O condition}
    end
else
    if not (freadable and flocked) then
	 if not (freadable or fwriteable) then ioresult := ord(inotopen)
	 else if not freadable then ioresult := ord(inotreadable)
	      else ioresult := ord(ifileunlocked)
    else begin
	 call (am, addr(f), readbytes, buf, frecsize, fpos);
	 freadmode := true; fbufvalid := false;   {set lazy I/O condition}
	 if ioresult = ord(ieof) then
	  if fistextvar and not feoln then
	    begin
	    buf[0] := ' ';
	    feoln := true;                      {'GHOST' end of line}
	    ioresult := ord(inoerror);
	    end;
	 end;
end;

procedure fwrite(anyvar f: fib;  anyvar buf: window);
begin with f do
 if not (fwriteable and flocked) then
   if not (freadable or fwriteable) then ioresult := ord(inotopen)
   else if not fwriteable then ioresult := ord(inotwriteable)
	else ioresult := ord(ifileunlocked)
 else
   begin
   call (am, addr(f), writebytes, buf, frecsize, fpos);
   freadmode := false;    fbufvalid := false;    {set non read mode condition}
   end;
end;


{sequential binary I/O }

procedure freadbytes(anyvar f: fib; anyvar buf: window; size: integer);
var i: integer;
begin with f do
  if not (freadable and flocked) then
       if not (freadable or fwriteable) then ioresult := ord(inotopen)
       else if not freadable then ioresult := ord(inotreadable)
	    else ioresult := ord(ifileunlocked)
  else begin
       call (am, addr(f), readbytes, buf, size, fpos);
       freadmode := true; fbufvalid := false;   {set lazy I/O condition}
       end;
end;

procedure fwritebytes(anyvar f: fib;  anyvar buf: window; size: integer);
begin with f do
 if not (fwriteable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not fwriteable then ioresult := ord(inotwriteable)
	   else ioresult := ord(ifileunlocked)
 else begin
      call (am, addr(f), writebytes, buf, size, fpos);
      freadmode := false;    fbufvalid := false;    {set non read mode}
      end;
end;



{UCSD BLOCKREAD AND BLOCKWRITE FUNCTIONS}

function fblockio (var f: fib; var buf: window;
			  nblocks, rblock: integer; doread: boolean): integer;
var blockbytes, filebytes: integer;
begin with f do
  if not (freadable or fwriteable) then ioresult := ord(inotopen)
  else if not flocked then ioresult := ord(ifileunlocked)
  else
    begin
    ioresult := ord(inoerror);
    if rblock >= 0 then fpos := rblock*fblksize
		   else fpos := fpos + (-fpos) mod fblksize;
    blockbytes := nblocks*fblksize;
    if doread then
	 begin
	 filebytes := fleof - fpos;
	 if filebytes < 0 then filebytes := 0;
	 if filebytes < blockbytes then
	   begin blockbytes := filebytes;
		 nblocks := (filebytes+(fblksize-1)) div fblksize;
	   end;
	 if blockbytes > 0 then
			call (am, addr(f), readbytes,  buf, blockbytes, fpos);
	 end
    else if blockbytes > 0 then
			call (am, addr(f), writebytes, buf, blockbytes, fpos);
    if ioresult = 0 then fblockio := nblocks  else fblockio := 0;
    end;
end;


(* This routine is useful when input can be edited *)

procedure killchar (anyvar f: fib; var sinx: integer);
var c: char;
begin
c :=  fbufferref(f)^[0];
with f, unitable^[funit]  do
  if c = chr(bs) then
    begin
    if sinx > 0 then
	 begin
	 sinx := sinx - 1;                {DELETE LAST CHARACTER FROM INPUT}
	 if uisinteractive then
	   call (am, addr(f), writebytes,
			   windowp(addr(' '#8))^, 2, 0);  {CLEAR LAST CHAR }
	 end
    else if uisinteractive then
	      call (am, addr(f), writebytes,
			   windowp(addr(#28' '))^, 1, 0);  {FIXUP CURSOR}
    end
  else if c = chr(del) then
    begin
    if uisinteractive then
      begin
      sinx := sinx + 1;                         {DEL IS A PRINTABLE CHARACTER}
      while sinx > 0 do
	begin
	call (am, addr(f), writebytes,
			   windowp(addr( #8' '#8))^, 3, 0);   {ZAP OUT LINE}
	sinx := sinx - 1;
	end;
      end;
    sinx := 0;
    end
  else sinx := sinx + 1;                        {CHARACTER OK};
fget(f);                                    {ABSORB THE CHARACTER}
end;


		       (* DEVICE CONTROL INTRINSICS *)

procedure fpage (var t: text);
begin write(t, eol, clearscr);
end;

procedure foverprint(var t: text);
begin write(t, eol);
end;

procedure fgotoxy(anyvar f: fib;      x, y:  integer);
begin
  with f do
    begin
    fxpos := x;         fypos := y;
    call(am, addr(f), setcursor, f, 0, 0);
    end;
end;

procedure fgetxy (anyvar f: fib;  var x, y:  integer);
begin
  with f do
    begin
    call(am, addr(f), getcursor, f, 0, 0);
    x := fxpos;         y := fypos;
    end;
end;


			  (* TEXT FILE INTRINSICS *)

procedure freadln (var t: text);
var index: integer;
begin
index := 0;
while not eoln(t) do killchar(t, index);        {handle characters typed}
get(t);                                         {dispose of end of line}
end (*FREADLN*) ;

procedure freadchar (var t:text; var ch: char);
begin
  fread(t, ch);              {a compiler optimization is in order here! }
end (*FREADCHAR*) ;

procedure fwritechar(var t: text; ch: char; rleng: shortint);
var s: packed array[1..255] of char;  i: integer;
begin
if rleng < 1 then rleng := 1 else for i := 1 to rleng - 1 do s[i] := ' ';
s[rleng] := ch;
fwritebytes(t, s, rleng);
end;

procedure freadword (var t:text; var i: shortint);
var  n: integer;
begin
read(t,n);      if (n<-32768) or (n>32767) then escape(-8);
i:=n;
end;

procedure freadint (var t:text; var i: integer);
label 1,2,3,4;
const maxdigits = 255;
var s: string[maxdigits];
    characters, spaces, nonspaces: integer;
    c: char;
begin
characters := 0; spaces := 0;
setstrlen(s,maxdigits);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^;        if ioresult <> 0 then goto 1;              { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; characters := characters + 1;
  get(t); c := t^; if ioresult <> 0 then goto 1;
  end;
nonspaces := 0;
if (c='-') or (c='+') then
  begin
  nonspaces := 1; s[1] := c;
  characters := characters + 1;
  get(t);  c := t^; if ioresult <> 0 then goto 1;
  end;
3: while (c>='0') and (c<='9') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  characters := characters + 1;
  c := t^; if ioresult <> 0 then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, characters);
  c := t^; if ioresult <> 0 then goto 1;
  if characters <= spaces then begin spaces := characters; goto 2; end
  else begin nonspaces := characters - spaces; goto 3; end;
  end;
4: setstrlen(s,nonspaces);
strread(s, 1, characters, i);
1:
end;

procedure fwriteword(var t:text; i,rleng: shortint);
begin  fwriteint(t,i,rleng)  end;

procedure fwriteint(var t:text; i: integer; rleng: shortint);
var   s: string255; j: integer;
begin setstrlen(s,0);
strwrite(s,1,j,i:rleng);
if ioresult = ord(inoerror) then fwritebytes(t, s[1], strlen(s));
end (*FWRITEINT*) ;

procedure fwritestr(var t: text; anyvar s: string80; rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := strlen(s)
  else if rleng > strlen(s) then
    begin
    fwritechar(t,' ',rleng-strlen(s));
    rleng := strlen(s);
    end;
  fwritebytes(t, s[1], rleng);
end (*FWRITESTR*);

procedure readpacstr(var t: text; anyvar p: window;
					   var len: integer; maxlen: integer);
label 1,2;
var   sinx: integer;   c: char;
begin
len := 0;
with fibp(addr(t))^ do
if not (freadable and flocked) then
      if not (freadable or fwriteable) then ioresult := ord(inotopen)
      else if not freadable then ioresult := ord(inotreadable)
	   else ioresult := ord(ifileunlocked)
else
 begin
 if unitable^[funit].uisinteractive then
   begin
   sinx := 0;
   repeat
     c := t^;
     if feoln or (ioresult <> ord(inoerror)) then goto 2;
     if (c=chr(bs)) or (c=chr(del)) then  killchar(t, sinx)
     else begin get(t); p[sinx] := c; sinx := sinx + 1; end;
   until sinx >= maxlen;
   2: len := sinx;
   end
 else
   begin
   c := t^;
   if (ioresult = ord(inoerror)) and not feoln then
     begin
     get(t); len := 1;
     if maxlen > 1 then
       begin
       call(am, addr(t), readtoeol, p[0], maxlen-1, fpos);
       if ioresult = ord(inoerror) then len := len + ord(p[0]);
       end;
     p[0] := c;
     end;
   end;
 end;
1:
end;

procedure freadstr(var t:text; var s: string);
var len: integer;
begin
 readpacstr(t, s[1], len, strmax(s));
 setstrlen(s, len);
end; (*FREADSTR*)

procedure freadpaoc(var t: text; var a: window; aleng: shortint);
  var sinx: integer;
begin
  readpacstr(t, a, sinx, aleng);
  while sinx < aleng do begin a[sinx] := ' ';sinx := sinx+1; end;
end; {freadpaoc}

procedure fwritepaoc(var t: text;  var a: window; aleng,rleng: shortint);
begin ioresult := ord(inoerror);
  if rleng < 0 then rleng := aleng
  else if rleng > aleng then
    begin
    fwritechar(t,' ',rleng-aleng);
    rleng := aleng;
    end;
  fwritebytes(t, a, rleng);
end (*FWRITEPAOC*) ;

procedure fwriteenum(var t: text; i,rleng: shortint; p: vptr);
var s: string255; dummy: integer;
begin setstrlen(s,0); dummy := 1;
fwritestrenum(s,dummy,i,rleng,p);
if ioresult = ord(inoerror) then fwritebytes(t,s[1],strlen(s));
end;

procedure freadenum(var t: text; var i: shortint; p: vptr);
label 1,2,3,4;
var s: string255;
    sinx, spaces, nonspaces: integer; c: char;
begin
sinx := 0; spaces := 0;
setstrlen(s, 255);
if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
else c := t^; if ioresult <> ord(inoerror) then goto 1;         { scs 1/17/83 }
2: while c = ' ' do
  begin
  spaces := spaces + 1; sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
nonspaces := 0;
if ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z')) then
  begin
  nonspaces := 1; s[1] := c;
  sinx := sinx + 1;
  get(t); c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
3: while ((c>='A') and  (c<='Z')) or ((c>='a') and (c<='z'))
      or ((c>='0') and (c<='9')) or (c = '_') do
  begin
  nonspaces := nonspaces + 1; s[nonspaces] := c; get(t);
  if nonspaces = strmax(s) then goto 4;
  sinx := sinx + 1; c := t^; if ioresult <> ord(inoerror) then goto 1;
  end;
if (c = chr(bs)) or (c = chr(del)) then
  begin
  killchar(t, sinx);
  c := t^; if ioresult <> ord(inoerror) then goto 1;
  if sinx <= spaces then  begin spaces := sinx; goto 2; end
  else  begin nonspaces := sinx - spaces; goto 3; end;
  end;
4: setstrlen(s, nonspaces); sinx := 1;
freadstrenum(s, sinx, i, p);
1:
end;

procedure fwritebool(var t: text; b: boolean; rleng: shortint);
var p: vptr;
begin
  p.i := addr(booltable);
  fwriteenum(t,ord(b),rleng,p);
end;

procedure freadbool(var t: text; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadenum(t,i,p);
  b := i=1;
end;


	(*  STRING I/O INTRINSICS *)

procedure freadstrchar(var s: string255; var p2: integer; var ch: char);
begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else  begin ioresult := ord(inoerror);
      ch := s[p2]; p2 := p2+1;
      end;
end;

procedure fwritestrchar(var s: string; var p2: integer;
						   ch: char; rleng: shortint);
var t: string[1];
begin setstrlen(t,1);
t[1] := ch;
if rleng < 1 then rleng := 1;
fwritestrstr(s,p2,t,rleng);
end;

procedure fwritestrint $alias 'FS_FWRITESTRINT'$
      (var t: string; var p2: integer; i: integer; rleng: shortint); external;

procedure fwritestrword(var s: string; var p2: integer; i,rleng: shortint);
begin
   fwritestrint(s,p2,i,rleng);
end;

procedure freadstrword(var s: string255;var p2: integer; var i: shortint);
var n: integer;
begin
strread(s,p2,p2,n);
if (n<-32768) or (n>32767) then escape(-8);
i := n;
end;

{procedure freadstrint(var s: string255; var p2, i: integer);
external; }

procedure fwritestrstr(var s: string;
		       var p2: integer; anyvar t: string255; rleng: shortint);
var i,tp2: integer;
begin ioresult := ord(inoerror);
if rleng <> 0 then
  begin tp2 := p2;
  if rleng < 0 then rleng := strlen(t);
  if (tp2<1) or (tp2>strlen(s)+1) then ioresult := ord(istrovfl)
  else if tp2+rleng-1>strmax(s) then
    ioresult := ord(istrovfl)
  else
    begin
    if rleng > strlen(t) then
      begin
      for i := tp2 to tp2-1+rleng-strlen(t) do s[i] := ' ';
      tp2 := tp2+rleng-strlen(t);
      end;
    if rleng > strlen(t) then rleng := strlen(t);
    moveleft(t[1],s[tp2],rleng);
    tp2 := tp2+rleng;
    if tp2-1 > strlen(s) then setstrlen(s,tp2-1);
    p2 := tp2;
    end;
  end;
end; {fwritestrstr}

procedure freadstrstr(var t: string255; var p2: integer; var s: string);
  label 1;
  var sx,k: shortint;
  begin
  sx := 0; setstrlen(s,0);
  if (p2 < 1) or (p2 > strlen(t)) then ioresult := ord(istrovfl)
  else
    begin ioresult := ord(inoerror);
    for k := p2 to strlen(t) do
      begin
      if sx >= strmax(s) then goto 1;
      sx := sx+1; s[sx] := t[k];
      end;
 1: setstrlen(s,sx); p2 := p2+sx;
    end;
  end;

procedure fwritestrpaoc(var s: string;
    var p2: integer; var a: window; aleng,rleng: shortint);
var t: string255;
begin
setstrlen(t,aleng);
moveleft(a,t[1],aleng);
fwritestrstr(s,p2,t,rleng);
end;


procedure freadstrpaoc(var s: string255; var p2: integer;
					      var a: window; aleng: shortint);
label 1;
var i,ainx,sinx: integer;
begin sinx := p2;
if (sinx<1) or (sinx > strlen(s)) then ioresult := ord(istrovfl)
else
  begin ioresult := ord(inoerror);
  for i := 0 to aleng-1 do a[i] := ' ';
  for ainx := 0 to aleng-1 do
    begin
    if sinx > strlen(s) then goto 1;
    a[ainx] := s[sinx];
    sinx := sinx+1;
    end;
  end;
1: if ioresult = ord(inoerror) then p2 := sinx;
end;

procedure freadstrenum(var s: string255;
				    var p2: integer; var i: shortint; p: vptr);
label 1;
const idlength = 80;
var t: string[idlength];
    q, j, tinx: integer; c: char;
    done: boolean;

begin
if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl)
else
  begin
  q := p2;
  while s[q] = ' ' do
    begin
    q := q + 1;
    if q > strlen(s) then begin ioresult := ord(istrovfl); goto 1; end;
    end;
  c := s[q];
  if ((c < 'A') or (c > 'Z')) and ((c < 'a') or (c > 'z')) then
	      begin ioresult := ord(ibadformat); goto 1; end;
  ioresult := ord(inoerror);
  tinx := 0; setstrlen(t, idlength);
  done := false;
  repeat
    tinx := tinx+1;
    t[tinx] := c;
    q := q + 1;
    if (q > strlen(s)) or (tinx = idlength) then done := true
    else begin c := s[q];
	 done := not (((c>='A') and (c<='Z')) or ((c>='a') and (c<='z'))
		   or ((c>='0') and (c<='9')) or (c = '_'));
	 end;
  until done;

  setstrlen(t, tinx); upc(t);
  j := p.i^-1; p.j := p.j+ sizeof(shortint);
  while p.s^<>t do
    begin
    j := j-1;
    if j < 0 then begin ioresult := ord(ibadformat); goto 1; end;
    p.j := p.j + strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  i := j; p2 := q;
  end;
1:
end; {freadenum}


procedure fwritestrenum (var s: string;
				  var p2: integer; i,rleng: shortint; p: vptr);
var k: shortint;
begin
if (i<0) or (i>=p.i^) then escape(-8)
else
  begin ioresult := ord(inoerror);
  k := p.i^-1;  {index of 1st entry}
  p.j := p.j+2;
  while k>i do
    begin k := k-1;
    p.j := p.j+strlen(p.s^)+2-ord(odd(strlen(p.s^)));
    end;
  fwritestrstr(s,p2,p.s^,rleng);
  end;
end; {fwritestrenum}

procedure fwritestrbool (var s: string;
				 var p2: integer; b: boolean; rleng: shortint);
var p: vptr;
begin
p.i := addr(booltable);
fwritestrenum(s,p2,ord(b),rleng,p);
end;

procedure freadstrbool(var s: string255; var p2: integer; var b: boolean);
var i: shortint;  p: vptr;
begin
  p.i := addr(booltable);
  freadstrenum(s,p2,i,p);
  b := i=1;
end;

procedure fstripname(s : fid; var pvname,ppath,pfname : string);
var
  tempfib : fib;
  lkind   : filekind;
  segs    : integer;
begin
  with tempfib do
  begin
    if scantitle(s,fvid,ftitle,segs,lkind) then
    begin
      funit := findvolume(fvid,true);
      if funit=0 then ioresult := ord(inounit)
      else
      begin
	call(unitable^[funit].dam,tempfib,funit,stripname);
	if ioresult=ord(inoerror) then
	begin
	  pvname := fvid;
	  ppath  := ftitle;
	  pfname := ftid;
	end;
      end;
    end
    else ioresult := ord(ibadtitle);
  end; { with }
end;

end  {file support}


@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.2
log
@Reversed fix for FSDdt00754 by checking out 28.2 (last version with only
good fixes), and adding in diffs between 29.2 and 31.2, which are a good
fix. 29.2 still contains bad fix for reference (was earlybird bits), but
31.3 does not.
Bad fix was on overwrite, due to trying to reopen file with ftitle already
stripped down to basename due to previous open. This caused a error on
overwrite from EDITOR where filename contained an SRM path; error was inofile.
SFB/RDQ/DEW
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@a512 1
var oldfleof: integer;  {for SR #5000235580, FSDdt00754 - SFB 12/01/88}
a518 7
   {for SR #5000235580, FSDdt00754 - SFB 12/01/88}
   if typ = readwrite then if fistextvar then
     begin
       ioresult := ord(ibadfiletype);
       goto 1;
     end;
  {end this part of fix. SFB}
a557 26

	    {next is bugfix for SR #5000235580, FSDdt00754 - SFB 12/01/88
	     on "open(f,'abc[20]')", much different results re-opening abc than
	     the first time. First time was ok (size was right), but re-opening
	     caused varying allocations, usually much too large, due to the
	     unpredicatble size stretched to by stretchit. We will attempt to
	     correct the file size when stretchit allocates more than requested}

	    if fpeof > fpos then {stretched too much, so try to shrink file to
				  requested size.}
	      begin
		oldfleof:=fleof;
		fleof:=fpos;    {tell DAM size to shrink to}
		fmodified:=true;{and tell it filesize has changed}
		call(dam, f, funit, closefile); {and trigger shrink}
		if ioresult <> ord(inoerror) then
		  begin goto 1; end;
		fpos:=0;        {tell DAM to use existing size}
		call(dam, f, funit, openfile);  {and reopen for user}
		if ioresult <> ord(inoerror) then
		  begin goto 1; end;
		fmodified:=true;
		fleof:=oldfleof;
		goto 1;         {so fmodified doesn't get set false}
	      end;              {end fix for SR #5000235580}

d565 1
a565 1
	  if typ = overwrite then goto 3;       {keepit - SFB}
d568 5
d1622 1
a1622 1
end   {file support}
@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.2
log
@Fix for Mutoh bug FSDdt02098 (multiple CPUs opening exclusive file
on SRM causes eof error--temp file created by mistake.)
SFB/RDQ
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@d550 11
a560 1
	  else if typ <> readonly then fisnew := true else goto 1
@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.2
log
@Added fix for "OPEN(F,'MYFILE[100]');" SR #5000235580, FSDdt00754.
Scott
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@d513 1
d520 7
d556 26
d589 1
a589 1
	  if typ = overwrite then goto 3;
a591 5
      if typ = readwrite then if fistextvar then
	begin
	if not fisnew then call (dam, f, funit, closefile);
	ioresult := ord(ibadfiletype); goto 1;
	end;
d1641 1
a1641 1
end  {file support}
@


28.3
log
@
ipws2rcs automatic delta on Mon Oct 31 10:34:17 MST 1988
:w
:q
@
text
@@


28.2
log
@Repaired FSDdt01559 - Pascal does not recognize write protect on
diskettes. Only procedure fileopen() changed. JWH - 10/27/88.
@
text
@d540 1
a540 1
               then  { <=== ADDED not is_unit_num 10/27/88 - JWH }
d568 1
a568 1
             { ^ ADDED not is_unit_num 10/27/88 - JWH }
@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@d461 46
d513 1
d526 3
d539 2
a540 1
	  if (ioresult<>ord(inofile)) and not verify then
d567 2
a568 1
	  if not verify then
@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.2
log
@Fixed \3\ and \0\ in 3rd open parameter. These are now invalid, and
create <data> files (-5622).
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d118 2
d710 5
d738 9
a746 6
    if ioresult = ord(inoerror) then      (* valid file type *)
      begin
	for fk := untypedfile to lastfkind do
	  if efttable^[fk] = feft then
	    fkind := fk;
	parse_tinfo := true;
@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.2
log
@fix of bug in parse_typeinfo.
don't use try recover in FS, because iocheck is off. Instead check
the ioresult to see if there was an error.
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@a729 1
  try
d731 1
a731 1
    if pos > strlen(typeinfo) then      (* valid file type *)
d737 2
a738 6
      end;

  recover
    begin
      ioresult := ord(inoerror);
      for fk := untypedfile to lastfkind do
d740 7
a746 3
	upc(typeinfo);
	if typeinfo = suffixtable^[fk] then
	    fkind := fk;
a747 1
    end;
@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.3
log
@Pws2unix automatic delta on Tue Oct 28 10:57:29 MEZ 1986
@
text
@@


4.2
log
@Initialize fb0 and fb1 to FALSE in initfibfields, called by finitb.
@
text
@d400 1
@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@d399 1
@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.4
log
@strread sets ioresult, this should not be passed back in parset.
@
text
@@


1.3
log
@Change in fhpopen. fileopen must be called with feft_flag instead of false.
@
text
@d739 3
a741 1
    for fk := untypedfile to lastfkind do
d747 1
@


1.2
log
@The 3rd parameter for fhpopen got an additional feature.
It can now be used to create a file with a specific eft
independent of the file names suffix. 
The parsing routines for this have been added and some
changes be made to fhpopen. There is also a change to
fileopen and all routines that call fileopen.
@
text
@d775 1
a775 1
 fileopen(f,typ,typ,false);     {changed 30-Jun-86 geli}
@


1.1
log
@Initial revision
@
text
@d457 4
a460 1
procedure fileopen(var f: fib; typ, styp: faccess);
d469 2
a470 1
  feft := efttable^[fkind];
d602 1
a602 1
  fileopen(f,writeonly,writeonly);
d616 1
a616 1
     fileopen(f, writeonly, typ);
d621 130
d752 4
d757 5
d765 11
a775 2
 f.foptstring := addr(option);
 fileopen(f,typ,typ);
d785 1
a785 1
 fileopen(f, writeonly,writeonly);
d795 1
a795 1
 fileopen(f, overwrite, writeonly);
@
