{ last mod 04-Jul-85 } {$X-} procedure ioinit(numfiles:integer); { initialize i/o variables, character table } var i :integer; fbp :^fbuf; begin if numfiles + 3 > MAXOPEN then error('Too many files requested.'); openlist[TRMIN].mode := IOREAD; openlist[TRMOUT].mode := IOWRITE; openlist[PRINTER].mode := IOWRITE; for i:=PRINTER+1 to PRINTER+numfiles do with openlist[i] do begin new(fbp); fbufptr := fbp; mode := IOAVAIL; end; for i:=PRINTER+numfiles+1 to MAXOPEN do openlist[i].mode := IONAVAIL; for i:=0 to 47 do chartbl[i] := 'X'; for i:=48 to 57 do chartbl[i] := 'D'; for i:=58 to 64 do chartbl[i] := 'X'; for i:=65 to 90 do chartbl[i] := 'U'; for i:=91 to 96 do chartbl[i] := 'X'; for i:=97 to 122 do chartbl[i] := 'L'; for i:=123 to 127 do chartbl[i] := 'X'; end; function open(var name:textline; accmode:integer):filedesc; { open a file with the given name for access in the given mode } var intname :string80; found :boolean; i :integer; function openfile(accmode:integer; var iostuff: ioblock; var intname: string80) :boolean; { machine-dependent subroutine, attempts to open file with name intname and mode accmode. If open ok, initializes iostuff and returns 'true'. If error, returns 'false' } var foundcz :boolean; j :integer; fs :integer; mode2 :byte; begin {$i-} openfile := false; with iostuff do begin assign(filevar,intname); if ioresult = 0 then begin mode2 := accmode and MODEMASK; if mode2 = IOREAD then begin reset(filevar); lastrec := filesize(filevar); reccnt := 0; bufindx := FBUFSIZE+1; end else if mode2 = IOWRITE then begin rewrite(filevar); bufindx := 1; end else if mode2 = IOAPPEND then begin reset(filevar); fs := filesize(filevar); if (ioresult = 0) and (fs > 0) then { file already exists } begin seek(filevar,fs-1); blockread(filevar,fbufptr^,1); seek(filevar,fs-1); { to overwrite last sector of file } j := 1; foundcz := false; while (j<=SECTSIZE) and (not foundcz) do begin foundcz := ord(fbufptr^[j]) = eofchar; if not foundcz then j:=j+1; end; bufindx := j; end else { file doesn't exist, create it } begin rewrite(filevar); bufindx := 1; end; end; if ioresult = 0 then begin openfile := true; mode := accmode; { flag file open } eofflag := false; end; end {$i+} end; end; { openfile } begin { open } intname := makestring(name); open := IOERROR; found := false; i := 1; while (i<=MAXOPEN) and (not found) do begin found := (openlist[i].mode = IOAVAIL); if found then begin if openfile(accmode,openlist[i],intname) then open := i; end else i := i + 1; end; end { open }; {$X+} procedure remove(var name:textline); { removes a file } var filvar :file; intname :string80; begin {$i-} intname := makestring(name); assign(filvar,intname); {$i+} if ioresult = 0 then erase(filvar); end; procedure putc(c:character); { puts 1 character to std. output } begin if c = NEWLINE then writeln else write(chr(c)); end; {$b-} function keyin(var c:character):character; { gets a char. from the keyboard, doesn't echo it} var ch :char; begin read(Kbd,ch); c := ord(ch); if (c = eofchar) then c := ENDFILE else if c = CR then c := NEWLINE; keyin := c; end; {$b+} function getc(var c:character):character; { get 1 character from keyboard, echo it to screen} var ch :char; begin c := keyin(c); putc(c); getc := c; end; function getbyte(var b:byte; fd:filedesc): boolean; { reads a binary byte from the file, returns false if physical end of file } begin getbyte := true; with openlist[fd] do begin if eofflag then getbyte := false else begin if (bufindx > FBUFSIZE) then begin if eof(filevar) then begin getbyte := false; eofflag := true; end else begin {$i-} blockread(filevar,fbufptr^[1],FBUFSIZE div SECTSIZE); {$i+} if not (ioresult in [$99,0]) then error('Disk read error'); end; bufindx := 1; end; b := fbufptr^[bufindx]; if bufindx and (SECTSIZE-1) = 0 then {don't read past last record} begin reccnt:=reccnt+1; if reccnt>=lastrec then eofflag := true; end; bufindx := bufindx + 1; end; end; end; { getbyte} function getcf(var c:character; fd: filedesc):character; { get a character from a file } var junk :boolean; b :byte; begin if fd = TRMIN then getcf := getc(c) else with openlist[fd] do begin if getbyte(b,fd) then begin c := b and $7F; if c = eofchar then begin c := ENDFILE; eofflag := true; end else begin if (c = CR) or (c = LF) then begin junk := getbyte(b,fd); c := NEWLINE; end end; end else c:=ENDFILE; getcf := c; end; end { getcf }; procedure putbyte(b:byte; fd:filedesc); { writes a binary byte to the file } begin with openlist[fd] do begin fbufptr^[bufindx] := b; bufindx := bufindx + 1; if bufindx > FBUFSIZE then begin {$i-} blockwrite(filevar,fbufptr^[1],FBUFSIZE div SECTSIZE); {$i+} if ioresult<>0 then error('Disk write error'); bufindx := 1; end end end; { putbyte } procedure putcf(c:character; fd: filedesc); { put a character to a file } begin if fd = TRMOUT then putc(c) else if fd = PRINTER then begin if c = NEWLINE then writeln(lst) else write(lst,chr(c)); end else begin if c = NEWLINE then { do cr first } begin putbyte(CR,fd); c := LF; end; putbyte(c,fd); end; end { putcf }; procedure pclose(fd: filedesc); { close a file } begin if not (fd in [TRMIN,TRMOUT,PRINTER]) then with openlist[fd] do begin if ((mode and MODEMASK) in [IOWRITE,IOAPPEND]) then { flush last buffer } begin if (mode and BINMASK) = 0 then putcf(eofchar,fd); if bufindx > 1 then blockwrite(filevar,fbufptr^[1], ((bufindx-2) div SECTSIZE)+1); end; close(filevar); mode := IOAVAIL; end; end; function getline(var s:textline; fd:filedesc; maxsize:integer):boolean; { gets line from file, returns false if end of file } var i :integer; c :character; begin i := 1; repeat if fd = TRMIN then {handle terminal line editing } begin s[i] := keyin(c); if (c=bks) then begin if (i>1) then begin i := i - 1; putc(bks); putc(space); putc(bks) end end else if ((c>=32) and (c<>127)) or (c=NEWLINE) then begin i := i + 1; putc(c) end end else begin s[i] := getcf(c,fd); i := i + 1; end until (c = NEWLINE) or (c = ENDFILE) or (i>=maxsize); if c = ENDFILE then i := i - 1; s[i] := EOS; getline := (c <> ENDFILE); end; procedure putstr(var str:textline; fd:filedesc); { put string in a file } var i :integer; begin i := 1; while str[i] <> EOS do begin putcf(str[i],fd); i := i + 1; end; end; function getfile(var filevar :filedesc; var prompt:textline; var name:textline; mode:integer) :boolean; { get file name from keyboard and open file, returns 'false' if CR entered after prompt } var openok,nofile :boolean; junk :boolean; fd :filedesc; lenname :integer; begin openok := false; repeat putstr(prompt,TRMOUT); {$u+} junk := getline(name,TRMIN,MAXSTR); {$u-} lenname := slength(name); if name[lenname] = NEWLINE then name[lenname] := EOS; nofile := (name[1] in [EOS,NEWLINE]); if not nofile then begin fd := open(name,mode); openok := fd <> IOERROR; if openok then begin filevar := fd; getfile := true; end else begin writeln; write('Can''t open: '); putstr(name,TRMOUT); writeln; end end else getfile := false; until openok or nofile; end;