/*
 * File: fsys.c
 *  Contents: close, exit, getenv, open, read, reads, remove, rename, [save],
 *   seek, stop, [system], where, write, writes, [getch, getche, kbhit]
 */

#include "..\h\config.h"
#include "..\h\rt.h"
#include "rproto.h"

#if MICROSOFT || SCO_XENIX
#define BadCode
#endif					/* MICROSOFT || SCO_XENIX */

#ifdef XENIX_386
#define register
#endif					/* XENIX_386 */

#if MACINTOSH
#if MPW
#include <Files.h>
#include <FCntl.h>
#include <IOCtl.h>
#define isatty(fd) (!ioctl((fd), FIOINTERACTIVE))
#define fflush(f) 0
#endif					/* MPW */
#endif					/* MACINTOSH */

/*
 * close(f) - close file f.
 */

FncDcl(close,1)
   {
   FILE *f;

   /*
    * Arg1 must be a file.
    */
   if (Arg1.dword != D_File) 
      RunErr(105, &Arg1);

   /*
    * Close Arg1, using fclose or pclose as appropriate.
    */

#if UNIX || VMS
   if (BlkLoc(Arg1)->file.status & Fs_Pipe) {
      BlkLoc(Arg1)->file.status = 0;
      MakeInt((long)((pclose(BlkLoc(Arg1)->file.fd) >> 8) & 0377), &Arg0);
      Return;
      }
   else
#endif					/* UNIX || VMS */

      f = BlkLoc(Arg1)->file.fd;

   fclose(f);
   BlkLoc(Arg1)->file.status = 0;

   /*
    * Return the closed file.
    */
   Arg0 = Arg1;
   Return;
   }

/*
 * exit(status) - exit process with specified status, defaults to 0.
 */

FncDcl(exit,1)
   {
   if (defshort(&Arg1, NormalExit) == Error) 
      RunErr(0, NULL);
   c_exit((int)IntVal(Arg1));
   }

/*
 * getenv(s) - return contents of environment variable s
 */

FncDcl(getenv,1)
   {

#ifndef EnvVars
   RunErr(-121, NULL);
#else					/* EnvVars */

   register char *p;
   register word len;
   char sbuf[256];


   /*
    * Make a C-style string out of Arg1
    */
   switch (cvstr(&Arg1, sbuf)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg1, sbuf);
         break;

      default:
         RunErr(103, &Arg1);
      }

   if ((p = getenv(StrLoc(Arg1))) != NULL) {	/* get environment variable */
      len = strlen(p);
      if (strreq(len) == Error) 
         RunErr(0, NULL);
      StrLen(Arg0) = len;
      StrLoc(Arg0) = alcstr(p, len);
      Return;
      }
   else 				/* fail if not in environment */
      Fail;
#endif					/* EnvVars */
   }

/*
 * open(s1,s2,s3) - open file s1 with mode s2 and attributes s3.
 */
FncDcl(open,3)
   {
   register word slen;
   register int i;
   register char *s;
   int status;
   char mode[4];
   extern FILE *fopen();
   char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen];
   char *openstring;
   FILE *f;

#ifdef OpenAttributes
   char sbuf3[MaxCvtLen];
   char *attrstring;
#endif					/* OpenAttributes */

/*
 * The following code is operating-system dependent [@fsys.01].  Make
 *  declarations as needed for opening files.
 */

#if PORT
Deliberate Syntax Error
#endif                                  /* PORT */

#if AMIGA || MACINTOSH
   /* nothing is needed */
#endif                                  /* AMIGA || MACINTOSH */

#if ATARI_ST || HIGHC_386 || MSDOS || OS2
   char untranslated;
#endif                                  /* ATARI_ST || HIGHC_386 ... */

#if MACINTOSH
#if LSC
   char untranslated;
#endif					/* LSC */
#endif					/* MACINTOSH */

#if MVS || VM
   char untranslated;
#if SASC
#include <lcio.h>
#endif					/* SASC */
#endif                                  /* MVS || VM */

#if UNIX || VMS
   extern FILE *popen();
#endif                                  /* MACINTOSH || UNIX || VMS */

/*
 * End of operating-system specific code.
 */


   /*
    * Arg1 must be a string and a C string copy of it is also needed.
    *  Make it a string if it is not one; make a C string if Arg1 is
    *  a string.
    */
   switch (cvstr(&Arg1, sbuf1)) {

      case Cvt:
         openstring = StrLoc(Arg1);
         if (strreq(StrLen(Arg1)) == Error)
            RunErr(0, NULL);
         StrLoc(Arg1) = alcstr(StrLoc(Arg1), StrLen(Arg1));
         break;

      case NoCvt:
         tended[1] = Arg1;
         ntended = 1;
         qtos(&tended[1], sbuf1);
         openstring = StrLoc(tended[1]);
         break;

      default:
         RunErr(103, &Arg1);
      }
   /*
    * s2 defaults to "r".
    */
   if (defstr(&Arg2, sbuf2, &letr) == Error)
      RunErr(0, NULL);

#ifdef OpenAttributes
   /*
    * Convert s3 to a string, defaulting to "".
    */
   ntended++;
   tended[ntended] = Arg3;
   if (ChkNull(tended[ntended]))
      tended[ntended] = emptystr;
   switch (cvstr(&tended[ntended], sbuf3)) {

      case Cvt:
         attrstring = StrLoc(Arg3);
         if (strreq(StrLen(Arg3)) == Error)
            RunErr(0, NULL);
         StrLoc(Arg3) = alcstr(StrLoc(Arg3), StrLen(Arg3));
         break;

      case NoCvt:
         qtos(&tended[ntended], sbuf3);
         attrstring = StrLoc(tended[ntended]);
         break;

      default:
         RunErr(103, &Arg3);
      }
#endif                                  /* OpenAttributes */

   if (blkreq((word)sizeof(struct b_file)) == Error)
      RunErr(0, NULL);
   status = 0;

/*
 * The following code is operating-system dependent [@fsys.02].  Provide
 *  declaration for untranslated line-termination mode, if supported.
 */

#if PORT
   /* nothing to do */
Deliberate Syntax Error
#endif                                  /* PORT */

#if AMIGA
   /* translated mode could be supported, but is not now */
#endif                                  /* AMIGA */

#if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || VM
   untranslated = 0;
#endif                                  /* ATARI_ST || HIGHC_386 ... */

#if MACINTOSH
#if LSC
   untranslated = 0;
#endif					/* LSC */
#endif					/* MACINTOSH */

#if UNIX || VMS
   /* nothing to do */
#endif                                  /* UNIX || VMS */

/*
 * End of operating-system specific code.
 */

   /*
    * Scan Arg2, setting appropriate bits in status.  Produce a run-time error
    *  if an unknown character is encountered.
    */
   s = StrLoc(Arg2);
   slen = StrLen(Arg2);
   for (i = 0; i < slen; i++) {
      switch (*s++) {
         case 'a':
         case 'A':
            status |= Fs_Write|Fs_Append;
            continue;
         case 'b':
         case 'B':
            status |= Fs_Read|Fs_Write;
            continue;
         case 'c':
         case 'C':
            status |= Fs_Create|Fs_Write;
            continue;
         case 'r':
         case 'R':
            status |= Fs_Read;
            continue;
         case 'w':
         case 'W':
            status |= Fs_Write;
            continue;

/*
 * The following code is operating-system dependent [@fsys.03].  Handle
 * untranslated line-terminator mode and pipes, if supported.
 */

#if PORT
         case 't':
         case 'T':
         case 'u':
         case 'U':
            continue;			/* no-op */
Deliberate Syntax Error
#endif					/* PORT */

#if AMIGA 
         case 't':
         case 'T':
         case 'u':
         case 'U':
            continue;			/* no-op */
#endif					/* AMIGA */

#if ATARI_ST || HIGHC_386 || MSDOS || OS2 || SASC
         case 't':
         case 'T':
            untranslated = 0;

#ifdef RecordIO
            status &= ~Fs_Record;
#endif					/* RecordIO */

            continue;
         case 'u':
         case 'U':
            untranslated = 1;

#ifdef RecordIO
            status &= ~Fs_Record;
#endif					/* RecordIO */

            continue;
#endif					/* ATARI_ST || HIGHC_386 || ... */

#ifdef RecordIO
         case 's':
         case 'S':
            untranslated = 1;
            status |= Fs_Record;
            continue;
#endif                                  /* RecordIO */

#if MACINTOSH
#if LSC
         case 't':
         case 'T':
            untranslated = 0;
            continue;
         case 'u':
         case 'U':
            untranslated = 1;
            continue;
#endif					/* LSC */
#endif					/* MACINTOSH */

#if UNIX || VMS
         case 't':
         case 'T':
         case 'u':
         case 'U':
            continue;			/* no-op */
         case 'p':
         case 'P':
            status |= Fs_Pipe;
            continue;
#endif					/* UNIX || VMS */

/*
 * End of operating-system specific code.
 */

         default:
            RunErr(209, &Arg2);
         }
      }

   /*
    * Construct a mode field for fopen/popen.
    */
   mode[0] = '\0';
   mode[1] = '\0';
   mode[2] = '\0';
   mode[3] = '\0';

   if ((status & (Fs_Read|Fs_Write)) == 0)   /* default: read only */
      status |= Fs_Read;
   if (status & Fs_Create)
      mode[0] = 'w';
   else if (status & Fs_Append)
      mode[0] = 'a';
   else if (status & Fs_Read)
      mode[0] = 'r';
   else
      mode[0] = 'w';

/*
 * The following code is operating-system dependent [@fsys.04].  Handle open
 *  modes.
 */

#if PORT
   if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write))
      mode[1] = '+';
Deliberate Syntax Error
#endif                                  /* PORT */

#if AMIGA || UNIX || VMS
   if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write))
      mode[1] = '+';
#endif                                  /* AMIGA || UNIX || VMS */

#if ATARI_ST
   if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
      mode[1] = '+';
      mode[2] = untranslated ? 'b' : 'a';
      }
   else mode[1] = untranslated ? 'b' : 'a';
#endif                                  /* ATARI_ST */

#if HIGHC_386 || OS2
   if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
      mode[1] = '+';
      mode[2] = untranslated ? 'b' : 't';
      }
   else mode[1] = untranslated ? 'b' : 't';
#endif                                  /* HIGHC_386 || OS2 */

#if MACINTOSH
#if LSC
   untranslated = 0;
#endif					/* LSC */
#endif					/* MACINTOSH */

#if MVS || VM
   if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
      mode[1] = '+';
      mode[2] = untranslated ? 'b' : 0;
      }
   else mode[1] = untranslated ? 'b' : 0;
#endif                                  /* MVS || VM */

/*
 * End of operating-system specific code.
 */

   /*
    * Open the file with fopen or popen.
    */

#ifdef OpenAttributes
#if SASC
#ifdef RecordIO
      f = afopen(openstring, mode, status & Fs_Record ? "seq" : "",
                 attrstring);
#else					/* RecordIO */
      f = afopen(openstring, mode, "", attrstring);
#endif                                  /* RecordIO */
#endif                                  /* SASC */

#else                                   /* OpenAttributes */

#if UNIX || VMS
   if (status & Fs_Pipe) {
      if (status != (Fs_Read|Fs_Pipe) && status != (Fs_Write|Fs_Pipe))
         RunErr(209, &Arg2);
      f = popen(openstring, mode);
      }
   else
#endif                                  /* UNIX || VMS */

      f = fopen(openstring, mode);
#endif                                  /* OpenAttributes */

   /*
    * Fail if the file cannot be opened.
    */
   if (f == NULL)
      Fail;

   /*
    * Return the resulting file value.
    */
   Arg0.dword = D_File;
   BlkLoc(Arg0) = (union block *) alcfile(f, status, &Arg1);
   ntended = 0;
   Return;
   }

/*
 * read(f) - read line on file f.
 */
FncDcl(read,1)
   {
   register word slen, rlen;
   register char *sp;
   int status;
   static char sbuf[MaxReadStr];
   FILE *f;

   /*
    * Default Arg1 to &input.
    */
   if (deffile(&Arg1, &input) == Error) 
      RunErr(0, NULL);

   /*
    * Get a pointer to the file and be sure that it is open for reading.
    */
   f = BlkLoc(Arg1)->file.fd;
   status = (int)BlkLoc(Arg1)->file.status;
   if ((status & Fs_Read) == 0) 
      RunErr(212, &Arg1);

#ifdef StandardLib
   if (status & Fs_Writing) {
      fseek(f, 0L, SEEK_CUR);
      BlkLoc(Arg1)->file.status &= ~Fs_Writing;
      }
   BlkLoc(Arg1)->file.status |= Fs_Reading;
#endif					/* StandardLib */

   /*
    * Use getstrg to read a line from the file, failing if getstrg
    *  encounters end of file. [[ What about -2?]]
    */
   StrLen(Arg0) = 0;
   do {

#ifdef RecordIO
      if ((slen = (status & Fs_Record ? getrec(sbuf, MaxReadStr, f) :
                                        getstrg(sbuf, MaxReadStr, f)))
          == -1) Fail;
#else					/* RecordIO */
      if ((slen = getstrg(sbuf,MaxReadStr,f)) == -1)
         Fail;
#endif                                  /* RecordIO */

      /*
       * Allocate the string read and make Arg0 a descriptor for it.
       */
      rlen = slen < 0 ? (word)MaxReadStr : slen;
      if (strreq(rlen) == Error) 
         RunErr(0, NULL);
      sp = alcstr(sbuf,rlen);
      if (StrLen(Arg0) == 0)
         StrLoc(Arg0) = sp;
      StrLen(Arg0) += rlen;
      } while (slen < 0);
   Return;
   }

/*
 * reads(f,i) - read i characters on file f.
 */
FncDcl(reads,2)
   {
   register word cnt;
   long tally;
   int status;
   FILE *f;

   /*
    * Arg1 defaults to &input and Arg2 defaults to 1 (character).
    */
   if ((deffile(&Arg1, &input) == Error) ||
       (defshort(&Arg2, 1) == Error)) 
      RunErr(0, NULL);

   /*
    * Get a pointer to the file and be sure that it is open for reading.
    */
   f = BlkLoc(Arg1)->file.fd;
   status = (int)BlkLoc(Arg1)->file.status;
   if ((status & Fs_Read) == 0) 
      RunErr(212, &Arg1);

#ifdef StandardLib
   if (status & Fs_Writing) {
      fseek(f, 0L, SEEK_CUR);
      BlkLoc(Arg1)->file.status &= ~Fs_Writing;
      }
   BlkLoc(Arg1)->file.status |= Fs_Reading;
#endif					/* StandardLib */

   /*
    * Be sure that a positive number of bytes is to be read.
    */
   if ((cnt = IntVal(Arg2)) <= 0) 
      RunErr(205, &Arg2);

   /*
    * Ensure that enough space for the string exists and read it directly
    *  into the string space.  (By reading directly into the string space,
    *  no arbitrary restrictions are placed on the size of the string that
    *  can be read.)  Make Arg0 a descriptor for the string and return it.
    */
   if (strreq(cnt) == Error) 
      RunErr(0, NULL);
   if (strfree + cnt > strend)
      syserr("reads allocation botch");
   StrLoc(Arg0) = strfree;

#if AMIGA
   /*
    * The following code is special for Lattice 4.0 -- it was different
    *  for Lattice 3.10.  It probably won't work correctly with other
    *  C compilers.
    */
   if (IsInteractive(_ufbs[fileno(f)].ufbfh)) {
      if ((cnt = read(fileno(f),StrLoc(Arg0),cnt)) <= 0)
         Fail;
      StrLen(Arg0) = cnt;
      alcstr(NULL, cnt);
      Return;
      }
#endif					/* AMIGA */

   tally = longread(StrLoc(Arg0),sizeof(char),cnt,f);
   if (tally == 0)
      Fail;
   StrLen(Arg0) = tally;
   alcstr(NULL, (word)tally);
   Return;
   }

/*
 * remove(s) - remove the file named s.
 */

FncDcl(remove,1)
   {
   char sbuf[MaxCvtLen];

   /*
    * Make a C-style string out of Arg1
    */
   switch (cvstr(&Arg1, sbuf)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg1, sbuf);
         break;

      default:
         RunErr(103, &Arg1);
      }
   if (unlink(StrLoc(Arg1)) != 0)
      Fail;
   Arg0 = nulldesc;
   Return;
   }

/*
 * rename(s1,s2) - rename the file named s1 to have the name s2.
 */

FncDcl(rename,2)
   {
   char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen];

   /*
    * Make a C-style string out of Arg1
    */
   switch (cvstr(&Arg1, sbuf1)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg1, sbuf1);
         break;

      default:
         RunErr(103, &Arg1);
      }

   /*
    * Make a C-style string out of Arg2
    */
   switch (cvstr(&Arg2, sbuf2)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg2, sbuf2);
         break;

      default:
         RunErr(103, &Arg2);
      }

/*
 * The following code is operating-system dependent [@fsys.05].  Rename the
 *  file, and fail if unsuccessful.
 */

#if PORT
   /* need something */
Deliberate Syntax Error
#endif					/* PORT */

#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || VM || VMS
   {
   if (rename(StrLoc(Arg1),StrLoc(Arg2)) != 0)
      Fail;
   }
#endif					/* AMIGA || ATARI_ST ... */

#if UNIX
   if (link(StrLoc(Arg1),StrLoc(Arg2)) != 0)
      Fail;
   if (unlink(StrLoc(Arg1)) != 0) {
      unlink(StrLoc(Arg2));	/* try to undo partial rename */
      Fail;
      }
#endif					/* UNIX */

/*
 * End of operating-system specific code.
 */

   Arg0 = nulldesc;
   Return;
   }

#ifdef ExecImages
/*
 * save(s) - save the run-time system in file s
 */

FncDcl(save,1)
   {
   char sbuf[MaxCvtLen];
   int f, fsz;

   dumped = 1;

   /* if (ChkNull(Arg1)) { abort(); } */

   /*
    * Make a C-style string out of Arg1.
    */
   switch (cvstr(&Arg1, sbuf)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg1, sbuf);
         break;

      default:
         RunErr(103, &Arg1);
      }


   /*
    * Open the file for the executable image.
    */
   f = creat(StrLoc(Arg1), 0777);
   if (f == -1)
      Fail;
   fsz = wrtexec(f);
   /*
    * It happens that most wrtexecs don't check the system call return
    *  codes and thus they'll never return -1.  Nonetheless...
    */
   if (fsz == -1)
      Fail;
   /*
    * Return the size of the data space.
    */
   MakeInt(fsz, &Arg0);
   Return;
   }

#endif					/* ExecImages */

/*
 * seek(file,position) - seek to byte byte position in file.
 */

FncDcl(seek,2)
   {
   long l1;
   FILE *fd;

   if (Arg1.dword != D_File) 
      RunErr(-105, NULL);

   if (defint(&Arg2, &l1, 1L) == Error)
      RunErr(0, NULL);

   fd = BlkLoc(Arg1)->file.fd;

   if (BlkLoc(Arg1)->file.status == 0)
      Fail;
    if (l1 > 0) {

#ifdef StandardLib
       if (fseek(fd, l1 - 1, SEEK_SET) == -1)
#else					/* StandardLib */
       if (fseek(fd, l1 - 1, 0) == -1)
#endif					/* StandardLib */

          Fail;
       }
    else {

#ifdef StandardLib
       if (fseek(fd, l1, SEEK_END) == -1)
#else					/* StandardLib */
       if (fseek(fd, l1, 2) == -1)
#endif					/* StandardLib */
          Fail;
       }

#ifdef StandardLib
    BlkLoc(Arg1)->file.status &= ~(Fs_Reading | Fs_Writing);
#endif					/* StandardLib */

   Arg0 = Arg1;
   Return;
   }

/*
 * stop(a,b,...) - write arguments (starting on error output) and stop.
 */

FncDclV(stop)
    {
   register word n;
   char sbuf[MaxCvtLen];
   FILE *f;

#ifdef BadCode
   struct descrip temp;
#endif					/* BadCode */

   f = stderr;
   ntended = 1;
   /*
    * Loop through arguments.
    */

   for (n = 1; n <= nargs; n++) {

#ifdef BadCode 
      temp = Arg(n);			/* workaround for Microsoft C bug */
      tended[1] = temp;
#else					/* BadCode */
      tended[1] = Arg(n);
#endif					/* BadCode */

      if (tended[1].dword == D_File) {
         if (n > 1)
            putc('\n', f);
         if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) 
            RunErr(213, &tended[1]);
         f = BlkLoc(tended[1])->file.fd;

#ifdef StandardLib
         if (BlkLoc(tended[1])->file.status & Fs_Reading) {
            fseek(f, 0L, SEEK_CUR);
            BlkLoc(tended[1])->file.status &= ~Fs_Reading;
            }
         BlkLoc(tended[1])->file.status |= Fs_Writing;
#endif					/* StandardLib */
         }
      else {

         if (n == 1 && (k_output.status & Fs_Write) == 0)
            RunErr(-213, NULL);

#ifdef StandardLib
         if (n == 1) {
            if (k_output.status & Fs_Reading) {
               fseek(f, 0L, SEEK_CUR);
               k_output.status &= ~Fs_Reading;
               }
            k_output.status |= Fs_Writing;
         }
#endif					/* StandardLib */

         if (ChkNull(tended[1]))
            tended[1] = emptystr;
         if (cvstr(&tended[1], sbuf) == CvtFail) 
            RunErr(109, &tended[1]);
         putstr(f, &tended[1]);
         }
      }

   putc('\n', f);
   fflush(f);
   c_exit(ErrorExit);
   }

#ifdef SystemFnc
/*
 * system(s) - execute string s as a system command.
 */

FncDcl(system,1)
   {
   char sbuf[MaxCvtLen];
   char *systemstring;

   /*
    * Make a C-style string out of Arg1
    */
   switch (cvstr(&Arg1, sbuf)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case NoCvt:
         qtos(&Arg1, sbuf);
         break;

      default:
         RunErr(103, &Arg1);
      }
      systemstring = StrLoc(Arg1);

   /*
    * Pass the C string to the system() function and return the exit code
    *  of the command as the result of system().
    */

/*
 * The following code is operating-system dependent [@fsys.06].  Perform system
 *  call.  Should not get here unless system(s) is supported.
 */

#if PORT
Deliberate Syntax Error
#endif					/* PORT */

#if AMIGA || MSDOS || OS2 || UNIX
   MakeInt((long)((system(systemstring) >> 8) & 0377), &Arg0);
#endif					/* AMIGA || MSDOS || ... */

#if ATARI_ST || VMS
   MakeInt(system(systemstring), &Arg0);
#endif					/* ATARI_ST || VMS */

#if HIGHC_386 || MACINTOSH
   /* Should not get here */
#endif					/* HIGHC_386 */

#if MVS || VM
#if SASC && MVS
   {
      char *wprefix;
      wprefix = malloc(strlen(systemstring)+5);
                     /* hope this will do no harm... */
      sprintf(wprefix,"tso:%s",systemstring);
      MakeInt((long)system(wprefix), &Arg0);
      free(wprefix);
   }
#else					/* SASC && MVS */
   MakeInt((long)system(systemstring), &Arg0);
#endif					/* SASC && MVS */
#endif                                  /* MVS || VM */

/*
 * End of operating-system specific code.
 */
   Return;
   }

#endif					/* SystemFnc */
/*
 * where(file) - return current offset position in file.
 */

FncDcl(where,1)
   {
   FILE *fd;
   long ftell();
   long pos;

   if (Arg1.dword != D_File) 
      RunErr(-105, NULL);

   fd = BlkLoc(Arg1)->file.fd;

   if ((BlkLoc(Arg1)->file.status == 0))
      Fail;

#ifdef StandardLib
   MakeInt(pos = ftell(fd) + 1, &Arg0);
   if (pos == 0)
      Fail;  /* may only be effective on ANSI systems */
#else					/* StandardLib */
   MakeInt(ftell(fd) + 1, &Arg0);
#endif					/* StandardLib */

   Return;
   }

/*
 * write(a,b,...) - write arguments.
 */
FncDclV(write)
   {
   register word n;
   char sbuf[MaxCvtLen];
   FILE *f;

#ifdef RecordIO
   word status = k_output.status;
#endif					/* RecordIO */

#ifdef BadCode
   struct descrip temp;
#endif					/* BadCode */

   f = stdout;
   ntended = 1;
   tended[1] = emptystr;

   /*
    * Loop through the arguments.
    */
   for (n = 1; n <= nargs; n++) {

#ifdef BadCode
      temp = Arg(n);			/* workaround for Microsoft bug */
      tended[1] = temp;
#else					/* BadCode */
      tended[1] = Arg(n);
#endif					/* BadCode */

      if (tended[1].dword == D_File)	{	/* Current argument is a file */
         /*
          * If this is not the first argument, output a newline to the current
          *  file and flush it.
          */
         if (n > 1) {

#ifdef RecordIO
            if (status & Fs_Record)
               flushrec(f);
            else
#endif					/* RecordIO */

            putc('\n', f);
            fflush(f);
            }
         /*
          * Switch the current file to the file named by the current argument
          *  providing it is a file.  tended[1] is made to be a empty string to
          *  avoid a special case.
          */
         if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) 
            RunErr(213, &tended[1]);
         f = BlkLoc(tended[1])->file.fd;

#ifdef StandardLib
         if (BlkLoc(tended[1])->file.status & Fs_Reading) {
            fseek(f, 0L, SEEK_CUR);
            BlkLoc(tended[1])->file.status &= ~Fs_Reading;
            }
         BlkLoc(tended[1])->file.status |= Fs_Writing;
#endif					/* StandardLib */

#ifdef RecordIO
         status = BlkLoc(tended[1])->file.status;
#endif					/* RecordIO */

         tended[1] = emptystr;
         }
      else {	/* Current argument is a string */
         /*
          * On first argument, check to be sure that &output is open
          *  for output.
          */
         if (n == 1 && (k_output.status & Fs_Write) == 0)
            RunErr(-213, NULL);

#ifdef StandardLib
         if (n == 1) {
            if (k_output.status & Fs_Reading) {
               fseek(f, 0L, SEEK_CUR);
               k_output.status &= ~Fs_Reading;
               }
            k_output.status |= Fs_Writing;
         }
#endif					/* StandardLib */

         /*
          * Convert the argument to a string, defaulting to a empty string.
          */
         if (ChkNull(tended[1]))
            tended[1] = emptystr;
         if (cvstr(&tended[1], sbuf) == CvtFail) 
            RunErr(109, &tended[1]);

         /*
          * Output the string.
          */

#ifdef RecordIO
         if ((status & Fs_Record ? putrec(f, &tended[1]) :
                                   putstr(f, &tended[1])) == Failure)
#else					/* RecordIO */
         if (putstr(f, &tended[1]) == Failure)
#endif					/* RecordIO */
            RunErr(-214, NULL);
         }
      }
   /*
    * Append a newline to the file and flush it.
    */

#ifdef RecordIO
   if (status & Fs_Record)
      flushrec(f);
   else
#endif					/* RecordIO */

   putc('\n', f);
   if (ferror(f))
      RunErr(-214, NULL);

   fflush(f);

   /*
    * Return the last argument.
    */
   ntended = 0;
   Arg(0) = Arg(n - 1);
   Return;
   }

/*
 * writes(a,b,...) - write arguments without newline terminator.
 */

FncDclV(writes)
   {
   register word n;
   char sbuf[MaxCvtLen];
   FILE *f;

#ifdef BadCode
   struct descrip temp;
#endif					/* BadCode */

   f = stdout;
   ntended = 1;
   tended[1] = emptystr;

   /*
    * Loop through the arguments.
    */
   for (n = 1; n <= nargs; n++) {

#ifdef BadCode
      temp = Arg(n);			/* workaround for Microsoft bug */
      tended[1] = temp;
#else					/* BadCode */
      tended[1] = Arg(n);
#endif					/* BadCode */

      if (tended[1].dword == D_File)	{	/* Current argument is a file */
         /*
          * Switch the current file to the file named by the current argument
          *  providing it is a file.  tended[1] is made to be a empty string to
          *  avoid a special case.
          */
         if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) 
            RunErr(213, &tended[1]);
         f = BlkLoc(tended[1])->file.fd;

#ifdef StandardLib
         if (BlkLoc(tended[1])->file.status & Fs_Reading) {
            fseek(f, 0L, SEEK_CUR);
            BlkLoc(tended[1])->file.status &= ~Fs_Reading;
            }
         BlkLoc(tended[1])->file.status |= Fs_Writing;
#endif					/* StandardLib */

         tended[1] = emptystr;
         }
      else {	/* Current argument is a string */
         /*
          * On first argument, check to be sure that &output is open
          *  for output.
          */
         if (n == 1 && (k_output.status & Fs_Write) == 0) 
            RunErr(-213, NULL);

#ifdef StandardLib
         if (n == 1) {
            if (k_output.status & Fs_Reading) {
               fseek(f, 0L, SEEK_CUR);
               k_output.status &= ~Fs_Reading;
               }
            k_output.status |= Fs_Writing;
         }
#endif					/* StandardLib */

         /*
          * Convert the argument to a string, defaulting to a empty string.
          */
         if (ChkNull(tended[1]))
            tended[1] = emptystr;
         if (cvstr(&tended[1], sbuf) == CvtFail)
            RunErr(109, &tended[1]);
         /*
          * Output the string and flush the file.
          */
         if (putstr(f, &tended[1]) == Failure)
            RunErr(-214, NULL);

#if !MVS && !VM         /* forces record break on the 370! */
         fflush(f);
#endif					/* !MVS && !VM */

         }
      }
   /*
    * Return the last argument.
    */
   ntended = 0;
   Arg(0) = Arg(n - 1);
   Return;
   }

#ifdef KeyboardFncs
/*
 * getch() - return a character from console.
 */

FncDcl(getch,0)
   {
   unsigned char c;
   int i;
   i = getch();
   if (i<0)
      Fail;
   if (strreq((word)1) == Error)
      RunErr(0, NULL);
   c = (unsigned char) i;
   StrLoc(Arg0) = alcstr((char *)&c,(word)1);
   StrLen(Arg0) = 1;
   Return;
   }

/*
 * getche() -- return a character from console with echo.
 */

FncDcl(getche,0)
   {
   unsigned char c;
   int i;
   i = getche();
   if (i<0)
      Fail;
   if (strreq((word)1) == Error)
      RunErr(0, NULL);
   c = (unsigned char) i;
   StrLoc(Arg0) = alcstr((char *)&c,(word)1);
   StrLen(Arg0) = 1;
   Return;
   }

/*
 * kbhit() -- Check to see if there is a keyboard character waiting to
 *  be read.
 */

FncDcl(kbhit,0)
   {
   if (kbhit()) {
      Arg0 = nulldesc;
      Return;
      }
   else Fail;
   }
#endif					/* KeyboardFncs */