/*$Header: /a/rathlin/disk/src/master/edml/EDML4/fam.src/UPTODATE/RCS/io.c,v 5.1 91/09/05 18:24:16 edml Exp $*/
/* AM: C library dependence reduced to May 86 ANSI C draft */
/* NICK: famflush() incorporated */
/* NICK, Jan '88: Overhauled to allow streams which aren't files (eg.
                  pipes) - required more intelligence in dealing with
                  our own pseudo-fids
   NICK: Feb '88: read/write made a bit more bulletproof (famread/famwrite will
                  retry, ExportState catches truncated writes.
 */

#include <stdio.h>
#ifdef __STDC__
#  include <string.h>   /* for memcmp, strcpy etc. */
#endif
#include "globdefs.h"
#include "structs.h"
#include "globvars.h"
#include "io.h"
#include "ncglobs.h" 

#define MAXSTREAMS 20        /* 20 is all unix gives and probably suffices */

extern FILE *std_input, *std_log;

/* NICK: Ok, this is how it works now. Our pseudo-ids are now called
         FAM_FDESC's (Fam file descriptors), and are small integers as
         before. They index into an array of FAMSTREAM records. For a
         FAMSTREAM Foo, Foo.FileDescr is -1 and Foo.FilePtr is NULL if not
         active. If Foo.FileDescr >= 0, then this is the real unix file
         descriptor. If Foo.FilePtr != NULL, then this is the real unix
         file pointer.
 */
/* RJG 28-Sep-89 ignore all the stuff about NULL being invalid for emas!
   stdio is NULL on emas -- see alterations below and also definition of
   isatty_ in system.h */
#ifdef EMAS
# define NULL ((FILE *) 0xffffffff)
#endif

extern LWord *BegOfX, *OldEnd;

FAMSTREAM Streams[MAXSTREAMS];
static int FlushStreams;

/*AJG: native code version flag, to allow hybrid type persistace */

LWord hybrid_native_version;

LWord read_hybrid_type(c)    /* allow reading and writing of type info */
LWord c;                     /* note that cant write old style heap :-) */
{
  if (c>0) hybrid_native_version = c;
  return(hybrid_native_version);
}


faminitio()
{  int i;
   for (i=0; i<MAXSTREAMS; i++)
   {
      Streams[i].FileDescr = -1;
      Streams[i].FilePtr = NULL;
   }

  /* Establish standard streams as file ptrs (for no good reason) */
/*rjg beware
 * EMAS stdin is 0 = NULL which confuses everything
 */
#ifdef CWIN
   Streams[0].FilePtr = (FILE *)Streams;  /* Junk non-zero values */
   Streams[1].FilePtr = (FILE *)Streams;
   Streams[2].FilePtr = (FILE *)Streams;
#else
   Streams[0].FilePtr = stdin;
   Streams[1].FilePtr = stdout;
   Streams[2].FilePtr = stderr;
#endif
}

/* because there is no portable way to use 'fid's we use stdio and
   generate our own pseudo-fids.... */
FAM_FDESC famopen(file, mode)
   char *file, *mode;
  /* Open a *file*, so fill in a file pointer in a FAMSTREAM. */

{  int i;
   for (i=0; i<MAXSTREAMS; i++)
      if ((Streams[i].FileDescr < 0) && (Streams[i].FilePtr == NULL))
      {
         FILE *f = fopen(file, mode);
#ifndef EMAS /*RJG see above*/
         return (f == NULL ? -1 : (Streams[i].FilePtr = f, i));
#else /* NULL is no longer zero */
         return (f == 0 ? -1 : (Streams[i].FilePtr = f, i));
#endif
      }

   return -1;    /* none spare */
}

/* ifdef unix? */
#ifndef RISC_OS

FAM_FDESC famregstream(fid)
  /* This registers an already opened file descriptor (eg. to a pipe) with the
     I/O system, giving the Fam's stream index for it.
   */

{  int i;
   for (i=0; i<MAXSTREAMS; i++)
      if ((Streams[i].FileDescr < 0) && (Streams[i].FilePtr == NULL))
      {
         Streams[i].FileDescr = fid;
         return(i);
      }

   return -1;    /* none spare */
}

/* Bullet-proof read. UNUSED - wrong behaviour for pipes. */
int FidRead(fid, buf, len)
int fid;
char *buf;
int len;
{
   int i, restlen;

   restlen = len;
   while (restlen > 0)
      {
         i = read(fid, buf, restlen);
         if (i < 0)  return i;		     		/* Error? */
	 else if (i == 0)  return(len-restlen);		/* assume EOF */
	 restlen -= i;
	 buf += i;
	 if (restlen != 0)  printf("[Fam: Read retry]\n");
		/* If we read <len, but >0, keep going */
      }

   return len;
}

#endif


/* famread() is rather like fread() but more rationally interactively. */
/* it returns 0 at eof, like read() not fread() though.                */
/* RJG changed famread to return requested size for non-ttys */
int famread(pseudo_fid, buf, len)
   FAM_FDESC pseudo_fid;
   register char *buf;
   register int len;
{
   register int i, ch;
   register FILE *fp;

/*rjg* BEWARE EMAS compiler (brain dead) has stdio==0==NULL
     * thus need to make sure stream isn't standard before
     * seeing if it's FilePtr field is NULL
     */

   if ((fp = Streams[pseudo_fid].FilePtr) != NULL)
   {
      int interactive = famisatty(pseudo_fid);
      for (i = 0; i<len;)
      {
         if (pseudo_fid == 0 && std_input != 0)
         {   ch = getc(std_input);
/* Maybe leave EOF there at end of this file?
             if (ch == EOF)
             {   fclose(std_input);
                 std_input = 0;
             }
*/
         }
         else
#ifdef CWIN
         if (pseudo_fid == 0) ch = cwin_getchar();
         else
#endif
         ch = getc(fp);
#ifdef DOS386
/* Treat ^Z and ^D as EOF under DOS (Since I am used to ^D under Unix) */
         if (ch == ('Z' & 0x1f) || ch == ('D' & 0x1f)) ch = EOF;
#endif
         if (ch == EOF) return i;   /*  i==0 ? EOF : i; */
         buf[i++] = asciichar(ch);
         if ((interactive) && (ch == '\n')) return i;	/* should we only do this on tty? */
	                                                /* YES rjg */
      }
      return i;
   }
#ifndef RISC_OS
   else 				/* Normal read from some fid */
      return(read(Streams[pseudo_fid].FileDescr, buf, len));
#endif
}

#ifndef RISC_OS
/* Bullet-proof write */
int FidWrite(fid, buf, len)
int fid;
char *buf;
int len;
{
   int i;

   while (len > 0)
      {
	 i = write(fid, buf, len);
	 if (i < 0)  return i;
	 len -= i;
	 buf += i;
	 if (len != 0)  printf("[Fam: Write retry]\n");
      }

   return 0;		/* success */
}
#endif

void ml_fflush(FILE *f)
{
#ifdef CWIN
    cwin_ensure_screen();
#else
    fflush(f);
#endif
}

void ml_putchar(int c)
{
#ifdef CWIN
    if (std_log) /* I convert greek letters back to 'a, 'b etc */
    {   switch (c)
        {
    case 0x80: putc(' ', std_log); break;
    case 0x81: putc('-', std_log); break;
    case 0x82: putc('=', std_log); break;
    case 'l' | 0x80:
            putc('f', std_log); putc('n', std_log);
            break;
    case 'V' | 0x80:
            putc('\'', std_log);
            c = 'z';
            /* drop through */
    default:
            if (c & 0x80) putc('\'', std_log), c = latinOf[(c & 0x7f) - 'a'];
            putc(c, std_log);
            break;
        }
    }
    cwin_putchar(c);
#else
    if (std_log) putc(c, std_log);
    putc(c, stdout);
#endif
}

void ml_printf(char *fmt, ...)
{
    va_list a;
    int i;
    char tbuf[256];
    va_start(a, fmt);
    vsprintf(tbuf, fmt, a);
    va_end(a);
    for (i=0; tbuf[i]!=0; i++) ml_putchar(tbuf[i]);
}

/* Make this a macro, just to keep with the tradition, you know. */
/*	int FPWRITE(fp, buf, len)
	   FILE *fp;
	   char *buf;
	   int len;
 */
#define FPWRITE(fp, buf, len, res)\
   res = 0;\
   while (len > 0)\
{\
   i = fwrite(buf, len, 1, fp);\
   if (i < 0)\
      {\
         res = -1;\
         break;\
      }\
   len -= i;\
   buf += i;\
   if (len != 0)  printf("[Fam: Write retry]\n");\
}

int famwrite(pseudo_fid, buf, len)
   FAM_FDESC pseudo_fid;
   register char *buf;
   register int len;
{
   FILE *fp;
   int i, res;

   if ((fp = Streams[pseudo_fid].FilePtr) != NULL)/* use fwrite as before */
      {
     if (pseudo_fid == 1)
     {   for (i=0; i<len; i++) ml_putchar(buf[i]);
         return 0;
     }
	 FPWRITE(fp, buf, len, res);
	 return res;
      }
#ifndef RISC_OS
   else						/* Just a fid */
      return(FidWrite(Streams[pseudo_fid].FileDescr, buf, len));
#endif
}

int famisatty(pseudo_fid)
   FAM_FDESC pseudo_fid;
{
#ifdef CWIN
   if (pseudo_fid == 0) return  1;
   else return 0;
#else
   FILE *fp;
   if ((fp = Streams[pseudo_fid].FilePtr) != NULL)
      return(isatty_(fp));
   else
      return(0);				/* Pipes etc. just aren't? */
#endif
}

int famttywait(pseudo_fid)
   FAM_FDESC pseudo_fid;
{
   FILE *fp;

   if ((fp = Streams[pseudo_fid].FilePtr) != NULL)
      return(isatty_(fp) && !InputPossibleOn(fp));
   else
      return(0);				/* Pipe: pretend not a tty? */
}

/* famflush() is (always) called in OpWriteStream, so that writes to a tty get
   immediately flushed. However, its effect depends on the command-line
   "-b" (for "buffered") which will disable it. */

int famflush(i)
FAM_FDESC i;
{  FILE *fp = Streams[i].FilePtr;
   if ((fp != NULL) && isatty_(fp) && FlushStreams)  fflush(fp);
  /* Can't flush fid's! */

   return(0);
}

int famclose(i)
FAM_FDESC i;
{  if (Streams[i].FilePtr != NULL) fclose(Streams[i].FilePtr);
#ifndef RISC_OS
   else                            close(Streams[i].FileDescr);
#endif
   Streams[i].FileDescr = -1;
   Streams[i].FilePtr = NULL;
   return 0;
}

/* Temp defs - beware macro for Collect - only for SetupStreams */
#undef SaveRegs_
#undef RestoreRegs_
#define SaveRegs_     0
#define RestoreRegs_  0
#define Collect(x)    \
      FatalError("No room in heap to construct new streams")


/* New (version 3+) heap (.exp) file header record.
   Note all non-specified bits should be zero for upwards
   compatibility.  Size is 64 bytes.  */
typedef struct {
  LWord magic;
  LWord flags;
  LWord size;
  LWord *base;
  LWord stateoffset;
  LWord date;
  LWord version;
  LWord Junk;
#define HDRLWORDS 8
  char  subversioninfo[8];
     /* NICK: a string to carry any sub-version information (eg. "X10" for
        X-windows support) */
  LWord refsoffset;       /* 26/4/90 GMK start of refs area in filtered heap */
                          /* 29/6/91 AJG, added slightly differently */
  LWord nativeversion;  /*AJG: type of native code heap */
                       /* 0x100 = generic, 0x200 = 68000, 0x202 = 68020, ... */
  char bytejunk[16];    
} HeapHeader;

#define EXPMAGIC 0xDECAACED    /* stupid non-palindromic bit pattern */
#define RESEXMAGIC 0xEDACCADE  /* its resex */
#define FlagWORDPTRS 0x80000000

/* ImportState(fileName, noisy, recon):
 *    Reads in an exported file (.EXP) and loads it into the heap.
 *    The file consists of a header record that has a byte count (h.size),
 *    an offset for all addresses in the file (h.base) and the position
 *    of the root of the state relative to the beginning (h.stateoffset).
 *    More fields as detailed above.
 *    This is followed by the heap itself which is loaded into the A space.
 *    The addresses in the heap are then relocated and the pointer to the
 *    root of the heap is then returned.
 */

LWord *ImportState(fileName, noisy, recon)
char *fileName; int noisy, recon;
{  char fname[80]; int ByteSexOK = 1; int heapspace, initialheap;
   int heapHasWordPtrs;
   FILE *f;
   HeapHeader h;
   int i; LWord *newobject, *objstart, nativetag = 0;
   LWord expmagic = EXPMAGIC, resexmagic = RESEXMAGIC; /* To get around
                                                          Gould bug */
   initialheap = ((BegOfASpace+TagSize) == MidOfASpace);
   heapspace = PtrDiff_(EndOfASpace, MidOfASpace)+TagSize;

   if (noisy) {
      if (initialheap) {printf("Image file %s ", fileName); fflush(stdout);}
      else {printf("Importing from %s ", fileName); fflush(stdout);}
      }

/* AM: rationalise ImportState and CreateInitialHeap sometime into
 *     (say) MapHeapFromFile.
 */
#ifdef acorn32016
   { extern int LoadFile() asm;
     int f;
     LWord bugfix1, *bugfix2; bugfix1 = HeapSize, bugfix2 = BegOfASpace;
     if ((f = LoadFile(fileName,strlen(fileName),HeapSize,BegOfASpace)) < 0)
        { fprintf(stderr, "cannot be read\n"); exit(f); }
     h = *(HeapHeader *)BegOfASpace;
     BegOfASpace = ByteAdd_(bugfix2,sizeof(HeapHeader));
     HeapSize = bugfix1 - sizeof(HeapHeader);
   }
#else
   strcpy(fname, fileName);
   if ((f = bopen_(fname)) == 0 && (f = bopen_(strcat(fname,".exp"))) == 0) {
         perror("\nFAM_ImportState"); exit(1); }

   if (bread_(f, &h, sizeof(HeapHeader)) != sizeof(HeapHeader))
     { FatalError("ImportState - not FAM image\n"); exit(1); }
#endif

   if (h.magic != expmagic)
     { if (h.magic != resexmagic)
        { FatalError("ImportState - not FAM image\n"); exit(1); }
       ByteSexOK = 0;
       for (i=0; i<HDRLWORDS; i++) lsexchange((&(h.magic))+i);
     }

   if (noisy && initialheap) printf("\n   ");
   if (noisy) {printf("(written on %s by FAM version %s%s)\n[Loading",
                 datestring(h.date), verstring(h.version), h.subversioninfo);
               fflush(stdout);}

/* RJG new state record (extra pointer for extensible constructor text
 * demands that old .exps cannot be run using new fam
 *
 * AJG, but minor version numbers can change
 */
   if ((h.version & 0xff00) < (VERSION & 0xff00))
     { FatalError("ImportState - saved state version incompatible with FAM"); }

   if (h.size > HeapSize) FatalError("Heap image bigger than heap size");

/*** WAS ***
#ifndef acorn32016
   if (bread_(f, (char *)BegOfASpace, h.size) != h.size) {
      FatalError("Malformed (truncated) FAM image"); exit(1); }
   fclose(f);
#endif
 ***     ***/
/*** NOW ***/
#ifndef acorn32016
   /*
    * Minor change on the next line - Sam, 24.7.87.
    * As delivered, new imported stuff was read in to *BegOfASpace,
    * zapping what was there before (sml.exp file?).  Changed destination
    * of incoming pseudocode to *(MidOfASpace-TagSize) which is the same
    * as *BegOfASpace the first time, but just higher than the end of the
    * last chunk read in thereafter.  I don't really understand this, but
    * it seems to work pretty well.
    */
   if (bread_(f, (char *)(MidOfASpace-TagSize), h.size) != h.size) {
      FatalError("Malformed (truncated) FAM image"); exit(1); }
   fclose(f);
#endif
/***     ***/

/* AM: h.base is not really an LWord *, it should really be changed
 * (including export code) to be a byte offset of
 * the State within the heap, then we could machine independently use
 * ByteAdd_(...)
 */

   heapHasWordPtrs = (h.flags & FlagWORDPTRS);

   objstart = MidOfASpace-TagSize;

/* if (noisy)
      {
	 printf(" (loaded at %x, heap base is %x)",
		(int) objstart, (int) h.base);
	 fflush(stdout);
      }
 */

/* 
 * AJG Native code: hard wired for now, later use lookup table
 */

   hybrid_native_version = h.nativeversion;
   switch (h.nativeversion) 
     {
     case 0 : /* old generic heap */
       if(noisy)printf(" Old Style Heap%c",7); /* beep at the user !!! */
	   h.refsoffset = 0; /* force proper filter first time */
	   hybrid_native_version = 0x100;  /* now will be new generic type */
           nativeok = 0; /* no go for native code */
       break;
     case 0x100 : /* generic heap */
       if(noisy) printf(" Generic Heap"); 
       nativeok = 0;  /* no go for native code */
     break;

#if mc68000 || mc68020
     case 0x200: /* 68000-40, but only use 68k instructions */
       if(noisy) printf(" Hybrid 68k Heap");
       nativeok = 1;  /* feel free to generate code ... */
     break;
#endif

#ifdef mc68020
     case 0x202: /* 68020,30,40 */
       nativeok = 1;
       if(noisy) printf(" Hybrid 68020 Heap");
     break;
#endif
      default: printf(" Foreign Heap (Converting for Generic Use)");
       nativetag = 1; /* tell the movement function to split texts */
       nativeok = 0;  /* dont generate native code !!! */
     }


#ifdef WORDPTRS
   if (!heapHasWordPtrs)
      {
	 if (noisy)  {printf(" (word aligning)"); fflush(stdout);}
	 h.base = (LWord *)(((LWord)h.base) >> 2);
      }
#endif

   newobject = (LWord *)ByteAdd_(MidOfASpace, h.stateoffset-(TagSize*4));

/* GMK Apr 90. h.refsoffset is used to mark the start of the 
   References area in those heaps which have been filtered into the
   `Pure and References' format. If h.refsoffset is 0 then the heap
   is not in pre-filtered format and hence the first garbage 
   collection performed must be a Partitioning collection. */

   if (h.refsoffset){
    BegOfRefs = (LWord *)ByteAdd_(MidOfASpace, h.refsoffset-(TagSize*4));}
   else {BegOfRefs = 0;}


   MidOfASpace = ByteAdd_(MidOfASpace, h.size);

   if (initialheap) CurrentState = (State *)newobject;
   else {
      if (!ByteSexOK)
        { FatalError("ImportState - wrong byte sex\n"); exit(1); }
      }

   if (!ByteSexOK)
   { if (noisy) { printf("...resexing"); fflush(stdout); }
     ChangeHeapSex(ByteSexOK);
   }

   if (recon) Reconfigure(h.base);
   else Relocate(objstart,h.base, heapHasWordPtrs, noisy, nativetag);
   if (noisy) printf("]\n");
   fflush(stdout);
   return(newobject);
}


/* ExportState(FileName, ChangeOfSexReq, endpoint)
 *    Outputs the binary representation of the currently active state to
 *    the file specified by the string FileName.  The file format is as
 *    described above under the ImportState function.
 */
int ExportState(FileName, ChangeOfSexReq, endpoint)
char *FileName; int ChangeOfSexReq; LWord *endpoint;
{  LWord   hsize, startoffset;
   HeapHeader h;
   FILE *f; int i;

   startoffset = 4;

   if (endpoint == NIL) {
      endpoint = MidOfASpace - TagSize;
      endpoint = BegOfX - TagSize; /* MK: This is a hacky fix */
      startoffset = (LWord)PtrDiff_(CurrentState, BegOfASpace); }

   for (i=0; i<sizeof(HeapHeader); i++) ((char *)(&h))[i] = 0;

   if ((f = bcreate_(FileName)) == 0)  {
      perror("\n\n\nExportML"); return(-1); }

   h.magic = EXPMAGIC;  h.date = DateInUnix();  h.version = VERSION;
   strcpy(h.subversioninfo, SUBVERSION);
   h.size = hsize = PtrDiff_(endpoint, BegOfASpace);
   h.stateoffset = startoffset;
   h.base = BegOfASpace;

/* GMK Apr 90. Refsoffset set to the offset from bottom of heap to 
   start of References area. */
   h.refsoffset = (LWord)PtrDiff_(BegOfRefs, BegOfASpace);

#ifdef WORDPTRS
   h.flags |= FlagWORDPTRS;
#endif
   h.nativeversion = hybrid_native_version;  /* the native code type */
   if (ChangeOfSexReq)
     { for (i=0; i<HDRLWORDS; i++) lsexchange((&(h.magic))+i); }

/* NICK: fixed this to catch truncated writes, rather than just check for
   -1. It should really be made bulletproof (see famread/write above).
 */
   if (bwrite_(f, &h, sizeof(HeapHeader)) != sizeof(HeapHeader) ||
       bwrite_(f, (char *)BegOfASpace, hsize) != hsize) {
      perror("\n\n\nExportML"); return(-1); }
   else fclose(f);
   return(0);
}


SetupStreams(flushing)
   int flushing;
{  Cons  *StreamList;   register LWord tmpreg; InputStream *inpstr;

/* AM: I have reservations about whether the streams stdin/out/err should
   be smashed on heap re-load, certain I agree for other streams, but since
   stdin/out/err always exist it seems sensible to keep them.  Comments?
*/
   for (StreamList = CurrentState->ActiveStreams;
        StreamList != NIL;
        hd_(StreamList) = famint_(-1), StreamList = tl_(StreamList));

   inpstr = (InputStream *)(CurrentState->StdIn);
   StreamList = (Cons *)inpstr;
   inpstr->fid = famint_(0);
   AllString_(new_string, 512); inpstr->buffer = new_string;
   inpstr->len = famint_(0); inpstr->pos = famint_(0);
   inpstr->next = NIL;

   tmpreg = (LWord)(CurrentState->StdOut);
   hd_(tmpreg) = famint_(1); tl_(tmpreg) = StreamList;
   StreamList = (Cons *)tmpreg;
   tmpreg = (LWord)(CurrentState->StdErr);
   hd_(tmpreg) = famint_(2); tl_(tmpreg) = StreamList;
   CurrentState->ActiveStreams = (Cons *)tmpreg;

   FlushStreams = flushing;
}

#ifdef READLINE
int famintread(pseudo_fid, buf, len)
   FAM_FDESC pseudo_fid;
   register char *buf;
   register int len;
{
   register int i, l;
   register char *s; char *ss;
   register FILE *fp;

/* famintread is only called for interactive reading using readline library*/
   if ((fp = Streams[pseudo_fid].FilePtr) != NULL)
   {
      int interactive = famisatty(pseudo_fid);
      rl_instream = fp;  /* maybe this is daft as only applicable to stdin */
      ss = readline(rl_fam_prompt);
      s = ss;
      if ((s) && (*s)) {add_history(s); l=strlen(s);}
      else l=0;
      for (i = 0, len -= 1; (i<len ) && (l);)
      {
	buf[i++] = *(s++); l--;
      }
      if (ss) {
	free(ss);
	buf[i++] = '\n';
      }
      return i;
   }
   return (-1);
 }


typedef struct env_entry {
  char *name;
  LWord *thing;
} env_entry;

typedef env_entry *environment;

static env_entry env [] = {
{"abstype",NULL},
{"and",NULL},
{"andalso",NULL},
{"as",NULL},
{"case",NULL},
{"datatype",NULL},
{"do",NULL},
{"else",NULL},
{"end",NULL},
{"exception",NULL},
{"fn",NULL},
{"fun",NULL},
{"handle",NULL},
{"if",NULL},
{"infix",NULL},
{"infixr",NULL},
{"let",NULL},
{"local",NULL},
{"nonfix",NULL},
{"of",NULL},
{"op",NULL},
{"open",NULL},
{"orelse",NULL},
{"raise",NULL},
{"rec",NULL},
{"then",NULL},
{"type",NULL},
{"val",NULL},
{"with",NULL},
{"withtype",NULL},
{"while",NULL},
  NULL
};

char *
fam_completion_fn (text,state)
     int state;
     char *text;
{
static environment e;
static int n;
char *result=NULL;
int diff;
/* state initially zero: setup if necessary */
  if (!state) {e=env; n=strlen(text);}
  diff=0;
  while ((e->name) && (!result) && (diff>=0)) {
    if ((diff=strncmp(text,e->name,n)) == 0) result=e->name;
    e++;
  }
  return result;
}

SetupReadline(argv0)
char *argv0;
{
/*  rl_show_star = 0;   no modified flag displayed */
  rl_readline_name = "edml"; /* should use argv0 .... not as nice as edml*/
  /* disable filename completion and only use fam function*/
  rl_completion_entry_function = (Function *)fam_completion_fn;

}
  
#endif
