-- (C) Copyright International Business Machines Corporation 23 January 
-- 1990.  All Rights Reserved. 
--  
-- See the file USERAGREEMENT distributed with this software for full 
-- terms and conditions of use. 
-- SCCS Info: @(#)stdio.pp	1.9 3/13/92

#include "typemark.h"

stdio: using (unix, unixint, cload, common, terminalIO)

process (q: stdioInitQ)
declare
  iArgs: stdioInit;
  cload: cloadFn;
  fopenQ: fopenQ;
  fopen: fopenxFn;
  fdopenQ: fdopenQ;
  fdopen: fdopenxFn;
  popenQ: popenQ;
  popen: popenxFn;
  tmpfileQ: tmpfileQ;
  tmpfile: tmpfilexFn;
  streamBuilder: buildStreamFn;
begin
  receive iArgs from q;
  discard q;
  cload := iArgs.cload;
  new iArgs.stdio;
  unwrap iArgs.stdio.clearerrno from polymorph#(cload(S("clearerrno"))) {init};
  unwrap iArgs.stdio.ctermid from polymorph#(cload(S("ctermid"))) {init};
  unwrap iArgs.stdio.cuserid from polymorph#(cload(S("cuserid"))) {init};
  unwrap iArgs.stdio.tmpnam from polymorph#(cload(S("tmpnam"))) {init};
  unwrap iArgs.stdio.access from polymorph#(cload(S("Access"))) {init};
  unwrap iArgs.stdio.readErrno from polymorph#(cload(S("read errno"))) {init};
  new fopenQ;
  connect iArgs.stdio.fopen to fopenQ;
  unwrap fopen from polymorph#(cload(S("fopen"))) {init};
  new fdopenQ;
  connect iArgs.stdio.fdopen to fdopenQ;
  unwrap fdopen from polymorph#(cload(S("fdopen"))) {init};
  new popenQ;
  connect iArgs.stdio.popen to popenQ;
  unwrap popen from polymorph#(cload(S("popen"))) {init};
  new tmpfileQ;
  connect iArgs.stdio.tmpfile to tmpfileQ;
  unwrap tmpfile from polymorph#(cload(S("tmpfile"))) {init};
  
  -- following process takes a raw stream and creates a complete
  -- stream record from it
  streamBuilder <- buildStreamFn#(procedure of program#(
      process (q: buildStreamQ)
      declare
	iArgs: buildStream;
	streamType: streamType;
	-- the two central CHermes functions for IO
	read: readStreamFn;
	write: writeStreamFn;
	-- following services are handled via calls to them
	getcQ: getCharQ;
	getsQ: getStringQ;
	fgetsQ: getBoundedStringQ;
	freadQ: getBoundedStringQ;
	putcQ: putCharQ;
	putsQ: putStringQ;
	fputsQ: putStringQ;
	fwriteQ: putSubStringQ;
	-- services for which specialized CHermes functions exist
	readWord: readWordFn;
	getwQ: getWordQ;
	writeWord: writeWordFn;
	putwQ: putWordQ;
	fclose: fclosexFn;
	fcloseQ: fcloseQ;
	pclose: pcloseFn;
	pcloseQ: pcloseQ;
	freopen: freopenxFn;
	freopenQ: freopenQ;
	clearerr: clearerrFn;
	clearerrQ: clearerrQ;
	ferror: ferrorFn;
	ferrorQ: ferrorQ;
	ferrno: readErrnoFn;
	ferrnoQ: readErrnoQ;
	feof: feofFn;
	feofQ: feofQ;
	fflush: fflushFn;
	fflushQ: fflushQ;
	fseek: fseekxFn;
	fseekQ: fseekQ;
	rewind: rewindFn;
	rewindQ: rewindQ;
	ftell: ftellFn;
	ftellQ: ftellQ;
	setlinebuf: setlinebufFn;
	setlinebufQ: setlinebufQ;
	fstat: fstatFn;
	fstatQ: fstatQ;
	fileno: filenoFn;
	filenoQ: filenoQ;
      begin
	receive iArgs from q;
	discard q;

	block declare
	  readI: readStreamInitFn;
	  writeI: writeStreamInitFn;
	  readWordI: readWordInitFn;
	  writeWordI: writeWordInitFn;
	  fcloseI: fcloseInitFn;
	  pcloseI: pcloseInitFn;
	  freopenI: freopenInitFn;
	  clearerrI: clearerrInitFn;
	  ferrorI: ferrorInitFn;
	  ferrnoI: ferrnoInitFn;
	  feofI: feofInitFn;
	  fflushI: fflushInitFn;
	  fseekI: fseekInitFn;
	  rewindI: rewindInitFn;
	  ftellI: ftellInitFn;
	  setlinebufI: setlinebufInitFn;
	  fstatI: fstatInitFn;
	  filenoI: filenoInitFn;
	begin
	  unwrap readI from polymorph#(iArgs.cload(S("readstream"))) {init};
	  read <- readStreamFn#(readI(iArgs.rawStream));
	  unwrap writeI from polymorph#(iArgs.cload(S("writestream"))) {init};
	  write <- writeStreamFn#(writeI(iArgs.rawStream));
	  unwrap readWordI from polymorph#(iArgs.cload(S("readword"))) {init};
	  readWord <- readWordFn#(readWordI(iArgs.rawStream));
	  unwrap writeWordI from polymorph#(iArgs.cload(S("writeword")))
	      {init};
	  writeWord <- writeWordFn#(writeWordI(iArgs.rawStream));
	  unwrap fcloseI from polymorph#(iArgs.cload(S("fclose"))) {init};
	  fclose <- fclosexFn#(fcloseI(iArgs.rawStream));
	  unwrap pcloseI from polymorph#(iArgs.cload(S("pclose"))) {init};
	  pclose <- pcloseFn#(pcloseI(iArgs.rawStream));
	  unwrap freopenI from polymorph#(iArgs.cload(S("freopen"))) {init};
	  freopen <- freopenxFn#(freopenI(iArgs.rawStream));
	  unwrap clearerrI from polymorph#(iArgs.cload(S("clearerr"))) {init};
	  clearerr <- clearerrFn#(clearerrI(iArgs.rawStream));
	  unwrap ferrorI from polymorph#(iArgs.cload(S("ferror"))) {init};
	  ferror <- ferrorFn#(ferrorI(iArgs.rawStream));
	  unwrap ferrnoI from polymorph#(iArgs.cload(S("ferrno"))) {init};
	  ferrno <- readErrnoFn#(ferrnoI(iArgs.rawStream));
	  unwrap feofI from polymorph#(iArgs.cload(S("feof"))) {init};
	  feof <- feofFn#(feofI(iArgs.rawStream));
	  unwrap fflushI from polymorph#(iArgs.cload(S("fflush"))) {init};
	  fflush <- fflushFn#(fflushI(iArgs.rawStream));
	  unwrap fseekI from polymorph#(iArgs.cload(S("fseek"))) {init};
	  fseek <- fseekxFn#(fseekI(iArgs.rawStream));
	  unwrap rewindI from polymorph#(iArgs.cload(S("rewind"))) {init};
	  rewind <- rewindFn#(rewindI(iArgs.rawStream));
	  unwrap ftellI from polymorph#(iArgs.cload(S("ftell"))) {init};
	  ftell <- ftellFn#(ftellI(iArgs.rawStream));
	  unwrap setlinebufI from polymorph#(iArgs.cload(S("setlinebuf")))
	      {init};
	  setlinebuf <- setlinebufFn#(setlinebufI(iArgs.rawStream));
	  unwrap fstatI from polymorph#(iArgs.cload(S("fstat"))) {init};
	  fstat <- fstatFn#(fstatI(iArgs.rawStream));
	  unwrap filenoI from polymorph#(iArgs.cload(S("fileno"))) {init};
	  fileno <- filenoFn#(filenoI(iArgs.rawStream));
	end block;
	
	-- create service queues and connect up exported capabilities
	new iArgs.stream;
	new getcQ; connect iArgs.stream.getc to getcQ;
	new getsQ; connect iArgs.stream.gets to getsQ;
	new fgetsQ; connect iArgs.stream.fgets to fgetsQ;
	new freadQ; connect iArgs.stream.fread to freadQ;
	new putcQ; connect iArgs.stream.putc to putcQ;
	new putsQ; connect iArgs.stream.puts to putsQ;
	new fputsQ; connect iArgs.stream.fputs to fputsQ;
	new fwriteQ; connect iArgs.stream.fwrite to fwriteQ;
	new getwQ; connect iArgs.stream.getw to getwQ;
	new putwQ; connect iArgs.stream.putw to putwQ;
	new fcloseQ; connect iArgs.stream.fclose to fcloseQ;
	new pcloseQ; connect iArgs.stream.pclose to pcloseQ;
	new freopenQ; connect iArgs.stream.freopen to freopenQ;
	new clearerrQ; connect iArgs.stream.clearerr to clearerrQ;
	new ferrorQ; connect iArgs.stream.ferror to ferrorQ;
	new ferrnoQ; connect iArgs.stream.ferrno to ferrnoQ;
	new feofQ; connect iArgs.stream.feof to feofQ;
	new fflushQ; connect iArgs.stream.fflush to fflushQ;
	new fseekQ; connect iArgs.stream.fseek to fseekQ;
	new rewindQ; connect iArgs.stream.rewind to rewindQ;
	new ftellQ; connect iArgs.stream.ftell to ftellQ;
	new setlinebufQ; connect iArgs.stream.setlinebuf to setlinebufQ;
	new fstatQ; connect iArgs.stream.fstat to fstatQ;
	new filenoQ; connect iArgs.stream.fileno to filenoQ;
	-- remember whether this stream was popened
	streamType := iArgs.streamType;
	return iArgs;
	-- now service individual calls
	block declare
	  readCode: readTermCode;
	  result: integer;
	  s: charstring;
	begin
	  while TRUE repeat
	    select
	    event getcQ
	      block declare
		args: getCharIntf;
	      begin
		receive args from getcQ;
		readCode <- readTermCode#(read(ONE,FALSE,s));
		select (readCode)
		where (readTermCode#'ERROR')
		  return args exception endOfInput;
		otherwise
		  remove args.char from c in s where (TRUE);
		  return args;
		end select;
	      end block;
	      
	    event getsQ
	      block declare
		args: getStringIntf;
		nl: char;
	      begin
		receive args from getsQ;
		args.string <- S("");
		while TRUE repeat
		  readCode <- readTermCode#(read(I(80),TRUE,s));
		  select (readCode)
		  where (readTermCode#'ERROR')
		    if B(I(size of args.string) > ZERO) then
		      return args;
		    else
		      return args exception endOfInput;
		    end if;
		    exit getsDone;
		  where (readTermCode#'COUNT')
		    merge s into args.string;
		  where (readTermCode#'NEWLINE')
		    -- gets strips the trailing newline
		    remove nl from c in s 
			where (B(I(position of c) = I(I(size of s) - ONE)));
		    merge s into args.string;
		    return args;
		    exit getsDone;
		  otherwise
		    exit cantHappen;
		  end select;
		end while;
	      on exit(getsDone)
	      end block;

	    event fgetsQ
	      block declare
		args: getBoundedStringIntf;
	      begin
		receive args from fgetsQ;
		readCode <- readTermCode#(read(args.count,TRUE,args.string));
		select (readCode)
		where (readTermCode#'ERROR')
		  return args exception endOfInput;
		otherwise
		  return args;
		end select;
	      end block;
	      
	    event freadQ
	      block declare
		args: getBoundedStringIntf;
	      begin
		receive args from freadQ;
		readCode <- readTermCode#(read(args.count,FALSE,args.string));
		select (readCode)
		where (readTermCode#'ERROR')
		  return args exception endOfInput;
		otherwise
		  return args;
		end select;
	      end block;

	    event putcQ
	      block declare
		args: putCharIntf;
	      begin
		receive args from putcQ;
		new s;
		insert char#(copy of args.char) into s;
		result <- I(write(s,ZERO,ONE));
		if B(result = ONE) then
		  return args;
		else
		  discard args;
		end if;
	      end block;

	    event putsQ
	      block declare
		args: putStringIntf;
		start: integer;
	      begin
		receive args from putsQ;
		start <- ZERO;
		while B(start < I(size of args.string)) repeat
		  result <- I(write(args.string,start,
		      I(I(size of args.string) - start)));
		  start <- I(start + result);
		end while;
		-- puts appends a newline character
		new s;
		insert char#'NL' into s;
		while B(I(write(s,ZERO,ONE)) = ZERO) repeat
		  -- keep trying until it succeeds
		end while;
		return args;
	      end block;

	    event fputsQ
	      block declare
		args: putStringIntf;
		start: integer;
	      begin
		receive args from fputsQ;
		start <- ZERO;
		while B(start < I(size of args.string)) repeat
		  result <- I(write(args.string,start,
		      I(I(size of args.string) - start)));
		  start <- I(start + result);
		end while;
		return args;
	      end block;

	    event fwriteQ
	      block declare
		args: putSubStringIntf;
		start: integer;
	      begin
		receive args from fwriteQ;
		start <- ZERO;
		block begin
		  while B(start < args.count) repeat
		    result <- I(write(args.string,start,
			I(args.count - start)));
		    if B(result = ZERO) then
		      exit done;
		    else
		      start <- I(start + result);
		    end if;
		  end while;
		  exit done;
		on exit(done)
		  args.count <- start;
		  return args;
		end block;
	      end block;
	      
	    event getwQ
	      block declare
		args: getWordIntf;
	      begin
		receive args from getwQ;
		if B(readWord(args.value)) then
		  return args exception endOfInput;
		else
		  return args;
		end if;
	      end block;
	      
	    event putwQ
	      block declare
		args: putWordIntf;
	      begin
		receive args from putwQ;
		if B(writeWord(args.value)) then
		  discard args;
		else
		  return args;
		end if;
	      end block;

	    event fcloseQ
	      block declare
		args: fclose;
	      begin
		receive args from fcloseQ;
		result <- I(fclose());
		if B(result = ZERO) then
		  return args;
		else
		  return args exception Failure;
		end if;
		exit closed;
	      end block;
	      
	    event pcloseQ
	      block declare
		args: pclose;
	      begin
		receive args from pcloseQ;
		call pclose();
		return args;
		exit closed;
	      end block;
	      
	    event freopenQ
	      block declare
		args: freopen;
	      begin
		receive args from freopenQ;
		if B(freopen(args.filename, args.type)) then
		  return args;
		else
		  return args exception CouldNotOpen;
		end if;
	      end block;
	      
	    event clearerrQ
	      block declare
		args: clearerr;
	      begin
		receive args from clearerrQ;
		send args to clearerr;
	      end block;

	    event ferrorQ
	      block declare
		args: ferror;
	      begin
		receive args from ferrorQ;
		send args to ferror;
	      end block;
	      
	    event ferrnoQ
	      block declare
		args: readErrno;
	      begin
		receive args from ferrnoQ;
		send args to ferrno;
	      end block;
	      
	    event feofQ
	      block declare
		args: feof;
	      begin
		receive args from feofQ;
		send args to feof;
	      end block;
	      
	    event fflushQ
	      block declare
		args: fflush;
	      begin
		receive args from fflushQ;
		send args to fflush;
	      end block;
	      
	    event fseekQ
	      block declare
		args: fseek;
	      begin
		receive args from fseekQ;
		result <- I(fseek(args.offset, args.seekType));
		if B(result = ZERO) then
		  return args;
		else
		  return args exception couldNotSeek;
		end if;
	      end block;
	      
	    event rewindQ
	      block declare
		args: rewind;
	      begin
		receive args from rewindQ;
		send args to rewind;
	      end block;
	      
	    event ftellQ
	      block declare
		args: ftell;
	      begin
		receive args from ftellQ;
		send args to ftell;
	      end block;
	      
	    event setlinebufQ
	      block declare
		args: setlinebuf;
	      begin
		receive args from setlinebufQ;
		send args to setlinebuf;
	      end block;
	      
	    event fstatQ
	      block declare
		args: fstat;
	      begin
		receive args from fstatQ;
		send args to fstat;
	      end block;
	      
	    event filenoQ
	      block declare
		args: fileno;
	      begin
		receive args from filenoQ;
		send args to fileno;
	      end block;
	      
	    otherwise
	      exit cantHappen;
	    end select;
	  end while;

	on (disconnected)
	  -- the stream was discarded ... close it properly before
	  -- terminating
	  block declare
	    junk: integer;
	  begin
	    select streamType
	    where (streamType#'normal')
	      call fclose(junk);
	    where (streamType#'pipe')
	      call pclose();
	    otherwise
	      -- hmm... just try using fclose
	      call fclose(junk);
	    end select;
	  end block;
	on exit (closed)
	on exit(cantHappen)
	  print S("exit(cantHappen) happened in stdio.buildstream");
	end block;
      end process));

  -- retrieve raw streams for stdin etc, and create stream records for
  -- them
  block declare
    stdinR: rawstream;
    stdoutR: rawstream;
    stderrR: rawstream;
    stdstreams: stdstreamsFn;
  begin
    unwrap stdstreams from polymorph#(iArgs.cload(S("stdstreams"))) {init};
    call stdstreams(stdinR, stdoutR, stderrR);
    iArgs.stdio.stdin <- stream#(
      streamBuilder(stdinR, streamType#'normal', cload));
    iArgs.stdio.stdout <- stream#(
      streamBuilder(stdoutR, streamType#'normal', cload));
    iArgs.stdio.stderr <- stream#(
      streamBuilder(stderrR, streamType#'normal', cload));
  end block;
  return iArgs;
  
  -- service requests for the various means of opening files
  block declare
    raw: rawStream;
  begin
    while TRUE repeat
      select
      event fopenQ
	block declare
	  args: fopen;
	begin
	  receive args from fopenQ;
	  if B(fopen(args.filename, args.type, raw)) then
	    args.stream <- stream#(
	      streamBuilder(raw, streamType#'normal', cload));
	    return args;
	  else
	    return args exception couldNotOpen;
	  end if;
	end block;

      event fdopenQ
	block declare
	  args: fdopen;
	begin
	  receive args from fdopenQ;
	  if B(fdopen(args.filedes, args.type, raw)) then
	    args.stream <- stream#(
	      streamBuilder(raw, streamType#'normal', cload));
	    return args;
	  else
	    return args exception couldNotOpen;
	  end if;
	end block;
	
      event popenQ
	block declare
	  args: popen;
	begin
	  receive args from popenQ;
	  if B(popen(args.command, args.type, raw)) then
	    args.stream <- stream#(
	      streamBuilder(raw, streamType#'pipe', cload));
	    return args;
	  else
	    return args exception couldNotOpen;
	  end if;
	end block;
	
      event tmpfileQ
	block declare
	  args: tmpfile;
	begin
	  receive args from tmpfileQ;
	  if B(tmpfile(raw)) then
	    args.stream <- stream#(
	      streamBuilder(raw, streamType#'normal', cload));
	    return args;
	  else
	    return args exception couldNotOpen;
	  end if;
	end block;
	
      otherwise
	exit cantHappen;
      end select;
    end while;
  end block;
  
on (disconnected)
on exit(cantHappen)
  print S("exit(cantHappen) happened in stdio");
end process
