/*$Header: /a/rathlin/disk/src/master/edml/EDML4/fam.src/UPTODATE/RCS/interp.c,v 5.1 91/09/05 18:24:08 edml Exp $*/

#include <stdio.h>
#include <math.h>

#ifndef transputer
#   include <signal.h>
#endif

#include "globdefs.h"
#include "structs.h"
#include "globvals.h"
#include "io.h"
#include "bcodes.h"
#include "debug.h"
/* native code include file */
#include "ncglobs.h"

#ifdef CWIN
#include "cwin.h"
#endif

#ifdef __STDC__
#  include <stdlib.h>
#else
#  define NOT_ANSI
#  include <errno.h>
#ifndef ARM
   extern int errno;
#endif
#endif

#ifdef DOS386
#include <errno.h>
#endif

#ifdef SRGP_GRAPHICS
#include <srgp/srgp.h>
#endif

#ifdef BSD
#ifdef PROFILER
DynSnapShot()  /* This is made short and sweet */
   {
     register SWord *FunUse;

     if(AJG_FP) {
       FunUse = (SWord *) &((AJG_FP->text)->ProfileVal);
       if(*FunUse>=0) (*FunUse)++;   /* -ve numbers are Compiler text's */
     }
   }
#endif
#endif

extern LWord *EndOfX;   /* for Marks */
extern int GCCount;     /* Inc GC */

double RealArg;

hoststring(mlname, hostname)
register String *mlname;
register char hostname[];
{
   register int cptr;
   for (cptr=0; cptr < stringlength_(mlname) && cptr < 127; cptr++)
      hostname[cptr] = hostchar(stringchar_(mlname)[cptr]);
   hostname[cptr] = 0;
}

/* Fill up ml string chars from host buffer.  Block transfer could
   be used on non-ebcdic machines.
*/
famstring(mlname, hostname)
register String *mlname;
register char hostname[];
{
   register int cptr;
   for (cptr=0; cptr < stringlength_(mlname); cptr++)
      stringchar_(mlname)[cptr] =  asciichar(hostname[cptr]);
}

stringofreal(s,r)
char *s;
double r;
{  int i, j, dotfound, expflag, Eflag;
   char buf[40];
   sprintf(buf, REALFMT, r);
   dotfound = 0;
   expflag = 0;
   Eflag = 0;
   for (i=0, j=0; i<=strlen(buf); i++)
   {  if (expflag==1 && buf[i] >= '0')
      {  expflag = 0;
         if (buf[i]=='0') continue;
      }
      switch (buf[i])
      {  case '+': continue;
         case '-': {  s[j++]='~'; continue;  }
         case 'e':
         case 'E': {  if (s[j-1]=='.') s[j++]='0';
                      s[j++]='E';
                      expflag = 1;
                      Eflag = 1;
                      continue;
                   }
         case '.': {  dotfound = 1; break; }
      }
      s[j++] = buf[i];
   }
   if (!dotfound && !Eflag) strcat(s,".0");
}

static SLWord hash(s)
register String *s;
/* AM: return +ve integer from string s.  Compatible with old VMS version */
{ LWord ans = 0;
  int i, len = stringlength_(s);
  static Byte HistoricalAccident[] = { 0, 0, 5, 0xC0 };
  for (i=len-1; i>=len-4; i--)
    ans = (ans << 8) + (i>=0 ? stringchar_(s)[i] : HistoricalAccident[i+4]);
  return (ans+len) & ~0x80000000;   /* ensure +ve */
}

#define RaiseExc_(m) {tmpreg = (m); goto FAMExc; }

prompt()
{
   char buff[80];
#ifdef CWIN
   printf("Do you wish to continue? ");
   fflush(stdout);
   {   int i = 0, c;
       while ((c = getchar()) != '\n' && c != EOF && i < 80)
          buff[i++] = c;
   }
#else
   fputs("Do you wish to continue? ",stdout);
   fflush(stdout);
   fgets(buff, 80, stdin);
#endif
#ifdef DEBUGinterp
   if (buff[0] == 't') TraceBack();
#endif
   if (buff[0] != 'y') exit(0);
}

InvalidOpcode(opcode)
int opcode;
{
   printf("Invalid opcode (%d) encountered.\n",opcode);
   prompt();
}

#ifdef DEBUGinterp
#  ifndef   NOTRACE
      TraceBack()
      {
         int i;
         for (i = FirstInst+1; ; i++) {
            if (i > TraceBackSize) i = 1;
            printf("%d\n",TraceBackList[i-1]);
            if (i == LastInst) break;
         }
      }
#  else
      TraceBack() {printf("Not in this version, rebuild without NOTRACE\n"); }
#  endif
   SnapShot()
   {
      DynamicOpcodeCount[nextbyte]++;
   }
#endif

int GenericRC = 0;
extern double GenericREAL(LWord a);

RunState()
{  /* the following register declarations are in approx usefulness order */
   register LWord     *AP;
   register LWord     tmpreg;
   register Byte      *PC;
#ifndef RISC_OS
   register LWord     *CP;
   register Closure   *FP;
#else
            LWord     *CP;   /* FREE UP a few more scratch regs on the ARM */
            Closure   *FP;
#endif

   LWord    *TrapTop, IntZero;
   LWord    *TrapStart; /*RJG this holds the position of the CP when
                         *an exception was raised (other than reraises
                         *by pattern matching
                         *NOTE that if multiple processes are used,
                         *there should be one of these for each process
                         */
   /* made static */
   char     cworkstring[128];
   int Suspending = 0;
   Process *tempproc;

   TrapStart = NIL; /**RJG**/
   faminitio();

#ifdef BSD
#ifdef PROFILER
    if(dynamicprof) SetUpDynSampler();
#endif
#ifdef NATIVE
    INIT_NC
#endif
#endif

#ifdef DEBUGsnapshot
   SetUpSampler();
#endif

   IntZero = INTZERO;

   RestoreProcessState();
   RestoreRegs_ ;

#ifdef sun
#  define locreg_
#else
#ifdef transputer
   /* BEWARE this next move - it makes all local vars in the fam into
      statics in the transputer, so that the C stack can fit into the
      on-chip RAM. So: NEVER say something like "locreg_ i = 42;"
      anywhere, since this will break things. */
#  define locreg_ static
#else
#  define locreg_ register
#endif
#endif

#  define NextInst goto interp
#  define ExitML goto mlexit ;

   for (;;) {
   interp:


#ifdef DEBUGinterp
      nextbyte = *PC++;
      OpcodeCount[nextbyte]++;
#ifndef   NOTRACE
      LastInst = (LastInst == TraceBackSize) ? 1 : LastInst + 1;
      if (FirstInst == LastInst)
         FirstInst = (FirstInst == TraceBackSize) ? 1 : FirstInst + 1;
      TraceBackList[LastInst-1] = nextbyte;
      if (TraceInst == 1) printf("%d\n",nextbyte);
#endif

#else
#     define   nextbyte   *PC++
#endif

#ifdef REGTRACE
      fprintf(tracefile, "%x:%d %x %x %x %x\n", PC-(Byte *)BegOfASpace,  *PC,
             (Byte *)AP-(Byte *)BegOfASpace,
             (Byte *)FP-(Byte *)BegOfASpace,
             (Byte *)CP-(Byte *)BegOfASpace,
             (Byte *)TrapTop-(Byte *)BegOfASpace);
      if (fulltrace)
      { int q;
        for (q=0; q<8; q++) fprintf(tracefile, " %x", AP[q]);
        fprintf(tracefile, "\n");
      }
#endif

#ifdef RISC_OS
      /* Check for escape pressed every 256 cycles - bug in signal handler */
      switch (nextbyte |  ( ++IntFlag & 0xFFFFFF00) ) {
#else
#ifdef CWIN
/*
 * Poll the window manager once every 4000 cycles - balance performance loss
 * against responsiveness here
 */
      switch (nextbyte |  ( ++IntFlag & 0xFFFFF000) ) {
#else
      switch (nextbyte |  IntFlag) {
#endif
#endif
      case OpTrouble:

      default:
         if (IntFlag) {
#ifdef RISC_OS
            if (IntFlag == 0x100) {
               if ( _kernel_escape_seen() ) {
                   IntFlag = 0;
                   RaiseExc_(Exc_Interrupt);
                 }
               else
                 { --PC;
                   IntFlag = 0;
                   NextInst;
                 }
              }
#endif
#ifdef CWIN
            if (IntFlag == 0x1000)
            {   cwin_poll_window_manager();
                if (cwin_interrupt_pending)
                {   cwin_interrupt_pending = 0;
                    IntFlag = 0;
                    RaiseExc_(Exc_Interrupt);
                }
                else
                {   --PC;
                    IntFlag = 0;
                    NextInst;
                }
            }
#endif
            IntFlag = 0;
            if (FloatExc) {
               FloatExc = 0; SetupFloatHandler();
               if (PC[-2] == OpFDivide) {RaiseExc_(Exc_FDiv); }
               if (PC[-2] == OpFTimes) {RaiseExc_(Exc_FTimes); }
               if (PC[-2] == OpFPlus) {RaiseExc_(Exc_FPlus); }
               RaiseExc_(Exc_FMinus);
               }
            else if (TimeOut) {
               int which; Process *proc;
               TimeOut = 0; PC--;
               SaveRegs_; SaveProcessState();
scheduleproc:  Seed = (23501 * Seed + 6923) % 32768;
               if (Seed < (32768/2)) {
                  CurrentState->WaitingLastProc = CurrentProcess->Next;
                  CurrentProcess = CurrentState->WaitingProcesses =
                         CurrentProcess->Next->Next; }
               else {
                  CurrentState->WaitingLastProc = CurrentProcess;
                  CurrentProcess = CurrentState->WaitingProcesses =
                         CurrentProcess->Next; }
               RestoreProcessState(); RestoreRegs_;

               if ((CurrentState->SuspendedProcesses != 0)
                   && SomeInputPossible(&which)) { Process *sproc;
                  sproc = CurrentState->SuspendedProcesses;
                  while (sproc->Flags != which) {
                     if (sproc->Next->Flags == which) {
                        proc = sproc->Next;
                        sproc->Next = sproc->Next->Next; sproc = proc;}
                     else sproc = sproc->Next; }
                  if (sproc == CurrentState->SuspendedProcesses) {
                     CurrentState->SuspendedProcesses = sproc->Next; }
                  sproc->Next = 0; sproc->Flags = 0;
                  if (CurrentProcess->Next == CurrentProcess)
                     CurrentState->WaitingLastProc = sproc;
                  sproc->Next = CurrentProcess->Next;
                  CurrentProcess->Next = sproc; }
               SetupTimeOut(); NextInst;
               }
            else RaiseExc_(Exc_Interrupt); }
         InvalidOpcode(PC[-1]);  NextInst;

/*<ff>Argument accessing primitives */

      case OpGetLocalB: OrdAssign_(*(--AP), AP[*PC++]); NextInst;
      case OpGetLocalW: OrdAssign_(*(--AP), AP[PCWord_]); NextInst;
      case OpGetLoc0:   OrdAssign_(*(--AP), *AP); NextInst;
      case OpGetLoc1:   OrdAssign_(*(--AP), AP[1]); NextInst;

      case OpGetFreeB:  *(--AP) = global_(FP)[(*PC++)-1]; NextInst;
      case OpGetFreeW:  *(--AP) = global_(FP)[(PCWord_)-1]; NextInst;
      case OpGetFree1:  *(--AP) = *(global_(FP)); NextInst; /* Ugh */

      case OpGetLiteralB:
         *(--AP) = literal_((FP -> text) -> literals)[*PC++]; NextInst;
      case OpGetLiteralW:
         *(--AP) = literal_((FP -> text) -> literals)[PCWord_]; NextInst;
      case OpGetLiteral1:
         *(--AP) = literal_((FP -> text) -> literals)[1]; NextInst;

      case OpCurrClos:  *(--AP) = (LWord)FP; NextInst;


/* Reference primitives */

      case OpRef:     AllRef_(new_ref, *AP); *AP = (LWord)new_ref; NextInst;

      case OpAt:      *AP = (((Ref *)(*AP)) -> at); NextInst;

      case OpAssign: { locreg_ LWord *obj;
         OrdAssign_((((Ref *)(*AP)) -> at), *AP++);
         obj=(LWord *)(*AP);
         if ((!(obj[-1] & ASSIGNED)) && ((LWord)obj <= (LWord)EndOfX))
           {EndOfASpace--;
            *EndOfASpace=(LWord)obj;
            obj[-1]=obj[-1] | ASSIGNED;
            if ((LWord)EndOfASpace <= (LWord)MidOfASpace)
               {SaveRegs_; Collect(0); RestoreRegs_;}
           } /* GMK Feb 90. Vector manipulation code. */
         *AP = NIL;
          NextInst;}

 /* AJG <the old version>
      case OpAssign:
         OrdAssign_((((Ref *)(*AP)) -> at), *AP++); *AP = NIL; NextInst;
*/
      case OpEqRef: { locreg_ LWord arg2;
         arg2 = *AP++; *AP = fambool_(arg2==*AP); NextInst; }

      case OpIncRef:
         (((Ref *)(*AP)) -> at) = famint_(cint_(((Ref *)(*AP)) -> at) + 1);
         *AP = NIL; NextInst;

      case OpDecRef:
         (((Ref *)(*AP)) -> at) = famint_(cint_(((Ref *)(*AP)) -> at) - 1);
         *AP = NIL; NextInst;

/*<ff>I/O primitives */

      case OpOpenStream: { FAM_FDESC fid; InputStream *inpstr; String *buffer;
         hoststring((String *)(*AP), cworkstring);
         if ((fid = famopen(cworkstring,"r")) < 0) {
           RaiseExc_(Exc_OpenStream); }
         else {
           AllInputStream_(new_instr);
           *AP = (LWord)new_instr;
           AllString_(new_string,512);
           buffer = new_string;
           inpstr = (InputStream *)(*AP);
           inpstr->fid = famint_(fid); inpstr->buffer = buffer;
           inpstr->len = famint_(0); inpstr->pos = famint_(0);
           inpstr->next = (LWord *)CurrentState->ActiveStreams;
           CurrentState->ActiveStreams = (Cons *)(inpstr); }
         NextInst; }

      case OpCreateStream: { FAM_FDESC fid;
         hoststring((String *)(*AP), cworkstring);
         if ((fid = famopen(cworkstring,"w")) < 0) {
           RaiseExc_(Exc_CreateStream); }
         else { AllCons_(new_cons, famint_(fid), CurrentState->ActiveStreams);
                *AP = (LWord)((CurrentState->ActiveStreams) = new_cons); }
         NextInst; }

      case OpReadStream: {
/* RJG 17-July-89  changed readstream to fail on negative string lengths */
         String *newstr; FAM_FDESC fid; InputStream *ist;
         int len, newlen;
         int d,i,j; char *s;
         if (((len = cint_(*AP++)) > 512) || (len<0)) {RaiseExc_(Exc_ReadStream);}
         if ((fid = cfile_(*AP)) < 0) { *AP = (LWord)EmptyString; NextInst; }
         ist = (InputStream *)(*AP); d = (cint_(ist->len) - cint_(ist->pos));

tryagain:if (d >= len) {
            AllString_(new_string, len); newstr = new_string;
            ist = (InputStream *)(*AP);
            j = cint_(ist->pos); s = (char *)(ist->buffer);
            for (i=0; i<len; i++) stringchar_(newstr)[i] = s[i+j];
            ist->pos = famint_(j+len); *AP = (LWord)newstr; NextInst; }

         if (famttywait(fid)) {
            *(--AP) = famint_(len); PC--;
            CurrentProcess->Flags = fid;
            Suspending++;
            goto removeprocess;
            }

         j=cint_(ist->pos); s = (char *)(ist->buffer);
         if (j != 0) {for (i=0; i<d; i++) s[i] = s[i+j];
                      ist->pos=famint_(0); ist->len=famint_(d);}

         if ((newlen = famread(fid,&(s[d]),512-d)) <= 0) {
            famclose(fid);
            ist->fid = famint_(-1);
            if (newlen != 0) {RaiseExc_(Exc_ReadStream);}
            else if (d == 0) {*AP = (LWord)EmptyString; NextInst; }
            else {len = d; goto tryagain; }
         }

         ist->len = famint_(d+newlen); ist->pos = famint_(0);
         if ((d = (cint_(ist->len) - cint_(ist->pos))) < len) len = d;
         goto tryagain; }

      case OpReadLine: {
         String *newstr; FAM_FDESC fid; InputStream *ist;
         int len, newlen; int d,i,j; char *s;

         if ((fid = cfile_(*AP)) < 0) { *AP = (LWord)EmptyString; NextInst; }
         ist = (InputStream *)(*AP); d = (cint_(ist->len) - cint_(ist->pos));
         s = (char *)(ist->buffer);

readagain:len = cint_(ist->len);
         for (i=cint_(ist->pos); i<len && s[i] != '\n'; i++);
         if ((d == 512) && (i == 512)) {RaiseExc_(Exc_ReadStream);}
         if (i < len) {
retstr:     len = i-(cint_(ist->pos))+1;
            AllString_(new_string, len); newstr = new_string;
            ist = (InputStream *)(*AP);
            j = cint_(ist->pos); s = (char *)(ist->buffer);
            for (i=0; i<len; i++) stringchar_(newstr)[i] = s[i+j];
            ist->pos = famint_(j+len); *AP = (LWord)newstr; NextInst; }

         if (famttywait(fid)) {
            PC--;
            CurrentProcess->Flags = fid;
            Suspending++;
            goto removeprocess;
            }

         j=cint_(ist->pos); s = (char *)(ist->buffer);
         if (j != 0) {for (i=0; i<d; i++) s[i] = s[i+j];
                      ist->pos=famint_(0); ist->len=famint_(d);}

         if ((newlen = famread(fid,&(s[d]),512-d)) <= 0) {
            famclose(fid);
            ist->fid = famint_(-1);
            if (newlen != 0) {RaiseExc_(Exc_ReadStream);}
            else if (d == 0) {*AP = (LWord)EmptyString; NextInst; }
            else { i = cint_(ist->len) - 1; goto retstr; } }

         ist->len = famint_(d+newlen); ist->pos = famint_(0);
         if ((d = (cint_(ist->len) - cint_(ist->pos))) < len) len = d;
         goto readagain; }

      case OpLookahead: {
         String *newstr; FAM_FDESC fid; InputStream *ist;
         int len, newlen; int d,i,j; char *s;

         if ((fid = cfile_(*AP)) < 0) { *AP = (LWord)EmptyString; NextInst; }
         ist = (InputStream *)(*AP); d = (cint_(ist->len) - cint_(ist->pos));

lookagain:if (d >= 1) {
            AllString_(new_string, 1); newstr = new_string;
            ist = (InputStream *)(*AP);
            j = cint_(ist->pos); s = (char *)(ist->buffer);
            stringchar_(newstr)[0] = s[j];
            *AP = (LWord)newstr; NextInst; }

         if (famttywait(fid)) {
            PC--;
            CurrentProcess->Flags = fid;
            Suspending++;
            goto removeprocess;
            }

         j=cint_(ist->pos); s = (char *)(ist->buffer);
         if (j != 0) {for (i=0; i<d; i++) s[i] = s[i+j];
                      ist->pos=famint_(0); ist->len=famint_(d);}

         if ((newlen = famread(fid,&(s[d]),512-d)) <= 0) {
            famclose(fid);
            ist->fid = famint_(-1);
            if (newlen != 0) {RaiseExc_(Exc_ReadStream);}
            else {*AP = (LWord)EmptyString; NextInst; } }

         ist->len = famint_(d+newlen); ist->pos = famint_(0);
         d = d+newlen;
         goto lookagain; }

      case OpReadToString: {
         FAM_FDESC fid;
         int len, newlen, start;  String *deststr; InputStream *ist;
         int d,i,j; char *s;
         if ((start = cint_(*AP++)) <= 0) {RaiseExc_(Exc_ReadToString);}
         start-- ; deststr = (String *)(*AP++);
         if ((len = stringlength_(deststr) - start) <= 0 || (len > 512))
            {RaiseExc_(Exc_ReadToString);}
         if ((fid = cfile_(*AP)) < 0) {*AP = famint_(0); NextInst; }

         ist = (InputStream *)(*AP); d = (cint_(ist->len) - cint_(ist->pos));
again:   if (d >= len) {
            j = cint_(ist->pos); s = (char *)(ist->buffer);
            for (i=0; i<len; i++) stringchar_(deststr)[i+start] = s[i+j];
            ist->pos = famint_(j+len); *AP = famint_(len); NextInst; }

         if (famttywait(fid)) {
            *(--AP) = (LWord)deststr; *(--AP) = famint_(++start); PC--;
            CurrentProcess->Flags = fid;
            Suspending++;
            goto removeprocess;
            }

         j=cint_(ist->pos); s = (char *)(ist->buffer);
         if (j != 0) {for (i=0; i<d; i++) s[i] = s[i+j];
                      ist->pos=famint_(0); ist->len=famint_(d);}

#ifdef READLINE
         if (famisatty(fid)) {newlen = famintread(fid,&(s[d]),512-d);}
         else newlen = famread(fid,&(s[d]),512-d);
#else
         newlen = famread(fid,&(s[d]),512-d);
#endif
         if (newlen  < 0)
            {RaiseExc_(Exc_ReadStream);}

         ist->len = famint_(d+newlen); ist->pos = famint_(0);
         if ((d = (cint_(ist->len) - cint_(ist->pos))) < len) len = d;

         if (d == 0) {*AP = famint_(0); NextInst; }
         goto again; }

      case OpWriteStream: {
         FAM_FDESC fid; String *s = (String *)*AP++;
         if ((fid = cfile_(*AP)) < 0) {RaiseExc_(Exc_LostStream);}
         if (famwrite(fid,stringchar_(s),stringlength_(s)) < 0)
            {RaiseExc_(Exc_WriteStream);}
         famflush(fid);
         *AP = NIL;  NextInst; }

      case OpCloseStream: { FAM_FDESC fid;
         if ((fid = cfile_(*AP)) < 0) {*AP = NIL;  NextInst; }
         if (recordlength_(*AP) > 2) {
            ((InputStream *)(*AP)) -> buffer = NIL;
            ((InputStream *)(*AP)) -> pos = famint_(0);
            ((InputStream *)(*AP)) -> len = famint_(0); }
         hd_(*AP) = famint_(-1); famclose(fid); *AP = NIL;  NextInst; }

      case OpInteractive: { FAM_FDESC fid;
         if ((fid = cfile_(*AP)) < 0) {RaiseExc_(Exc_LostStream);}
         *AP = fambool_(famisatty(fid));  NextInst; }

      case OpHeapType: {
        *AP = famint_(read_hybrid_type(cint_(*AP)));
        NextInst; }

/*<ff>Assembler primitives */

      case OpMakeText: { /* makes a Byte Code Text .... */
         int firstarg, textsize;

         if (BigNum_(firstarg = AP[3]) ||
             ((textsize = cint_(firstarg)) <= 0 )) {RaiseExc_(Exc_MakeText);}

         AllText_(new_text,  textsize+(sizeof(LWord)*2));
         cint_(*AP++); /* ignore this field for now */
         new_text -> PhiBC = BCTAG; /* A switch */
         new_text -> ProfileVal = cint_(*AP++); /* The usage cntr */
         new_text -> literals = (Literals *)(*AP++);
         *AP = (LWord)new_text;  NextInst; }

      case OpMakeNativeText: { /* the native code making version (3 args)*/
                               /* the (oldtext,size,lits)  */
         int firstarg, textsize,oldtextsize;
         Byte *pt1,*pt2;
         Text *old_text;

         if(nativeok) /* if native code generation ok */
           {
         if (BigNum_(firstarg = AP[1]) ||
             ((textsize = cint_(firstarg)) <= 0 )) {RaiseExc_(Exc_MakeText);}

         oldtextsize = bytecodelength_(AP[2]) -4; /* this is exact ! */
         textsize += oldtextsize; /* add the old one ... */

         AllText_(new_text, textsize + (sizeof(LWord)*2));
         new_text -> PhiBC = NCTAG; /* A nop */
         new_text -> ProfileVal = (oldtextsize-textsize)-(0x400);
                                      /* very -ve = native code texts */
         new_text -> literals = (Literals *)(*AP);
         pt1 = (Byte *) AP[2] + 8; /* BC text */
         pt2 = (Byte *) new_text + 8 + (textsize-oldtextsize); /* NC text */
         for(;textsize;textsize--) *pt2++ = *pt1++; /* byte copy the code */
         AP[2] =(LWord) new_text; /* this becomes the new text one */
       } else {
           old_text = (Text *) AP[2];  /* the original text */
         old_text -> PhiBC = BCTAG; /* A switch into interpreted mode */
         old_text -> ProfileVal = -1; /* -1 = not be considered */
         old_text -> literals = (Literals *)(*AP);
       }
         AP += 2; NextInst; }


      case OpStoreTextByte: { locreg_ LWord offset, textarg;
         offset = cint_(*AP++);  textarg = (*AP++);
         *(Byte *)(bytecode_(textarg) + offset) = cbyte_(*AP);
         *AP = NIL;  NextInst; }

      case OpStoreTextWord: { locreg_ LWord offset, textarg;
         offset = cint_(*AP++);  textarg = (*AP++);
         StoreWord_((bytecode_(textarg) + offset), cword_(*AP));
         *AP = NIL;  NextInst; }

      case OpStoreTextLong: { locreg_ LWord offset, textarg;
         offset = cint_(*AP++);  textarg = (*AP++);
         StoreLong_((bytecode_(textarg) + offset), cint_(*AP));
         *AP = NIL;  NextInst; }

/************ extras for native code generation (RJG) *********/

       case OpTextLength: {
          *AP = famint_(bytecodelength_(*AP)-4);  NextInst; }

       case OpFetchTextByte: { locreg_ LWord offset, textarg;
          offset = cint_(*AP++);  textarg = (*AP);
          *AP = famint_(*(Byte *)(bytecode_(textarg) + offset));
          NextInst; }

       case OpFetchTextWord: { locreg_ LWord offset, textarg;
          offset = cint_(*AP++);  textarg = (*AP);
          *AP=0;  /*AJG: why this ? */
          FetchWord_(*AP,(bytecode_(textarg) + offset));
          *AP = famint_(*AP);  NextInst; }

       case OpFetchTextLong: { locreg_ LWord offset, textarg;
          offset = cint_(*AP++);  textarg = (*AP);
          FetchLong_(*AP,(bytecode_(textarg) + offset));
          *AP = famint_(*AP); NextInst; }

/************                                   *************/


/*<ff>String operations */
      case OpEqString: {
         locreg_ LWord str1, str2; int len;
         str2 = *AP++;  str1 = *AP;
         *AP = fambool_((len = stringlength_(str1)) == stringlength_(str2) &&
                         memcmp(stringchar_(str1),stringchar_(str2),len) == 0);
         NextInst;
         }

      case OpDestString: {
         locreg_ LWord str1, str2; int len;
         str1 = *AP++;  str2 = AP[PCWord_];
         if (!((len = stringlength_(str1)) == stringlength_(str2) &&
               memcmp(stringchar_(str1),stringchar_(str2),len) == 0)) {
            RaiseExc_(Exc_Bind); }
         NextInst;
         }

#define comparestring(REL)  \
   {  locreg_ char *str2, *str1; \
      int len2, len1; \
      str2 = (char *)*AP++; str1 = (char *)*AP; \
      len2 = stringlength_(str2); len1 = stringlength_(str1); \
      *AP = fambool_(signed_(  \
               (tmpreg = memcmp(str1,str2,min(len1,len2))) != 0  \
                  ? tmpreg : len1-len2)  REL  0); }


      case OpStringLEQ:   comparestring(<=); NextInst;

      case OpStringLSS:   comparestring(<); NextInst;

      case OpStringGEQ:   comparestring(>=); NextInst;

      case OpStringGTR:   comparestring(>); NextInst;

      case OpExplode: { locreg_ LWord strindex;
/* beware 2 allocations */
         strindex = stringlength_(*AP)-1;
         *(--AP) = NIL;
         for (; signed_(strindex) >= 0; strindex--) {
            AllString_(new_string, 1);
            stringchar_(new_string)[0] = stringchar_(AP[1])[strindex];
            *(--AP) = (LWord)new_string;  /* In case of GC */
            AllCons_(new_cons, *AP, AP[1]);
            *(++AP) = (LWord)new_cons; }
         Squeeze1_(AP); NextInst; }

      case OpExpAscii: { locreg_ LWord strindex;
         strindex = stringlength_(*AP)-1;
         *(--AP) = NIL;
         for (; signed_(strindex) >= 0; strindex--) {
            AllCons_(new_cons, famint_(stringchar_(AP[1])[strindex]), *AP);
            *AP = (LWord)new_cons; }
         Squeeze1_(AP); NextInst; }

      case OpImplode: {
         locreg_ LWord numchars, destptr, srcptr;
         Cons *strlist; String *srcstr;

         numchars = 0;
         for (strlist= (Cons *)*AP; strlist != NIL; strlist= tl_(strlist))
              numchars += stringlength_(hd_(strlist));

         if (numchars == 0) { *AP = (LWord)EmptyString; NextInst; }
         AllString_(new_string, numchars); strlist = (Cons *)*AP;

         for (destptr=0; strlist != NIL; strlist = tl_(strlist)) {
            for (srcptr = 0, srcstr = (String *)hd_(strlist);
                 srcptr<stringlength_(srcstr); srcptr++, destptr++)
                stringchar_(new_string)[destptr] = stringchar_(srcstr)[srcptr];
            }
         *AP = (LWord)new_string;
         NextInst; }

      case OpImpAscii: {
         locreg_ LWord strlist, numchars, dptr;
         LWord nextch;

         if ((strlist = *AP) == NIL) { *AP = (LWord)EmptyString; NextInst; }
         for (numchars =1; (strlist = (LWord)tl_(strlist)) != NIL; numchars++);
         AllString_(new_string, numchars); strlist = *AP;

         for (dptr=0; strlist != NIL; strlist = (LWord)tl_(strlist), dptr++)
            if ((nextch=cint_(hd_(strlist))) > 255) {RaiseExc_(Exc_ImplodeAscii);}
            else stringchar_(new_string)[dptr] = nextch;
         *AP = (LWord)new_string;
         NextInst; }

      case OpStringLength:
         *AP = famint_(stringlength_(*AP));  NextInst;

      case OpSubString: {
         locreg_ LWord chptr, size;  LWord start; String *oldstr;
         if (signed_((size = cint_(*AP++))) < 0 ||
             (signed_(start = cint_(*AP++)-1) < 0) ||
             ((start + size) > stringlength_(*AP))) {RaiseExc_(Exc_Substring);}

         if (size == 0) { *AP = (LWord)EmptyString; NextInst; }
         AllString_(new_string, size); oldstr = (String *)*AP;

         for (chptr=0; chptr < size; chptr++)
            stringchar_(new_string)[chptr] = stringchar_(oldstr)[start+chptr];
         *AP = (LWord)new_string;
         NextInst; }

      case OpFetchByte: { locreg_ LWord offset, stringarg;
         offset = cint_(*AP++);  stringarg = *AP;
         *AP = famint_(*(Byte *)(stringchar_(stringarg) + offset));
         NextInst; }

      case OpStoreByte: { locreg_ LWord offset, stringarg;
         offset = cint_(*AP++);  stringarg = (*AP++);
         stringchar_(stringarg)[offset] = cbyte_(*AP);
         *AP = NIL;  NextInst; }

      case OpStringHash: {
         locreg_ LWord range;
         if (BigNum_(range = *AP++) ||
             (signed_(range = cint_(range)) <= 0)) {RaiseExc_(Exc_StringHash);}
         *AP = famint_(signed_(hash((String *)*AP)) % signed_(range));
         NextInst; }

      case OpMoveSubstring: {
         locreg_ LWord from, to;  LWord ptr, str, length, strsize;
         if ((signed_(length = cint_(*AP++)) < 0) ||
             (signed_(to = cint_(*AP++)-1) < 0) ||
             (signed_(from = cint_(*AP++)-1) < 0) ||
             (signed_(strsize = stringlength_(*AP)) < (from + length)) ||
             (strsize < (to + length))) {RaiseExc_(Exc_MoveSubstring);}

         if (from < to) {
            for (str = *AP, ptr = length-1; signed_(ptr) >= 0; ptr--)
               stringchar_(str)[to+ptr] = stringchar_(str)[from+ptr];}
         else {
            for (str = *AP, ptr = 0; ptr < length; ptr++)
               stringchar_(str)[to+ptr] = stringchar_(str)[from+ptr];}
         NextInst; }

      case OpStringOfLength: {
         locreg_ LWord size;
         if ((size = cint_(*AP)) == 0) {*AP = (LWord)EmptyString; NextInst;}
         if (signed_(size) < 0) {RaiseExc_(Exc_StringOfLength);}
/* AM: should be AllBuffer_ */
         AllString_(new_string, size);
         for (size--; signed_(size) >= 0;
              stringchar_(new_string)[size] = asciichar(' '), size--);
         *AP = (LWord)new_string;
         NextInst; }

      case OpOldScanStringUntilIn: {
         locreg_ LWord chptr, mptr;
         LWord target, match, matchlen, last, start, len;
         if ((signed_(len = cint_(*AP++)) < 0) ||
             (signed_(start = cint_(*AP++)) <= 0) ||
             (target = *AP++,
                (last = (start + len - 1)) > stringlength_(target)))
            {RaiseExc_(Exc_ScanString);}

         match = *AP; matchlen = stringlength_(match);  /* poxy VMS */
         for (chptr = start - 1, mptr = matchlen;
              ((chptr < last) && (mptr == matchlen)); ) {
            for (mptr = 0; mptr < matchlen; mptr++) {
               if (stringchar_(target)[chptr] == stringchar_(match)[mptr])
                  break; };
            if (mptr == matchlen) chptr++; }
         *AP = famint_(chptr+1); NextInst; }

      case OpOldScanStringWhileIn: {
         locreg_ LWord chptr, mptr;
         LWord target, match, matchlen, last, start, len;
         if ((signed_(len = cint_(*AP++)) < 0) ||
             (signed_(start = cint_(*AP++)) <= 0) ||
             (target = *AP++,
                (last = (start + len - 1)) > stringlength_(target)))
            {RaiseExc_(Exc_ScanString);}

         match = *AP; matchlen = stringlength_(match);  /* poxy VMS */
         for (chptr = start - 1, mptr = 0;
              ((chptr < last) && (mptr != matchlen)); ) {
            for (mptr = 0; mptr < matchlen; mptr++) {
               if (stringchar_(target)[chptr] == stringchar_(match)[mptr])
                  {chptr++; break;}
               }
            }
         *AP = famint_(chptr+1); NextInst; }

      case OpScanStringWhileIn: {
         locreg_ LWord from, i, code, stlen, masklen;
         char *str = (char *)(*AP++), *mask = (char *)(*AP++);
         stlen = stringlength_(str); masklen = stringlength_(mask);
         if (signed_(from = cint_(*AP++)) < 0) {RaiseExc_(Exc_ScanString);}
         code = cint_(*AP);
         for (; ((((i=str[from]) < masklen) ? (mask[i]) : 0) == code)
                && (from < stlen); from++) ;
         *AP = famint_(from); NextInst; }

      case OpScanStringUntilIn: {
         locreg_ LWord from, i, code, stlen, masklen;
         char *str = (char *)(*AP++), *mask = (char *)(*AP++);
         stlen = stringlength_(str); masklen = stringlength_(mask);
         if (signed_(from = cint_(*AP++)) < 0) {RaiseExc_(Exc_ScanString);}
         code = cint_(*AP);
         for (; ((((i=str[from]) < masklen) ? (mask[i]) : 0) != code)
                && (from < stlen); from++) ;
         *AP = famint_(from); NextInst; }

      case OpStringOfInt:
         {locreg_ LWord arg1 = *AP++;
          SaveRegs_;
          arg1 = GenericStringOfInt(arg1);
          RestoreRegs_;
          *--AP = arg1;
          NextInst;}

      case OpIntOfString:
         {locreg_ LWord arg1 = *AP++;
          SaveRegs_;
          arg1 = GenericIntOfString(arg1);
          RestoreRegs_;
          *--AP = arg1;
          if (GenericRC != 0) {RaiseExc_(GenericRC);}
          NextInst;}

/*<ff>Variant primitives */

#define Var(ARG) if (*AP == TRIV) *AP = famint_(ARG);      \
                 else {AllVar_(new_var, *AP, ARG); *AP = (LWord)new_var;}

#define Is(ARG) if (Immed_(*AP)) *AP = fambool_(*AP == famint_(ARG)); \
                else *AP = fambool_(varianttype_(*AP) == ARG)

#define As(ARG,EXC) if (Immed_(*AP))                               \
                       if (*AP != famint_(ARG)) {RaiseExc_(EXC);}       \
                       else *AP = TRIV;                                 \
                    else                                                \
                       if (varianttype_(*AP) != ARG) {RaiseExc_(EXC);}  \
                       else *AP = ((Variant *)(*AP)) -> field

      case OpVariant:   Var(PCWord_); NextInst;

      case OpVar0:      Var(0); NextInst;

      case OpVar1:      Var(1); NextInst;

      case OpQuaIs:     Is(PCWord_); NextInst;

      case OpIs0:       Is(0); NextInst;

      case OpIs1:       Is(1); NextInst;

      case OpQuaAs:     As(PCWord_, Exc_As); NextInst;

      case OpOutl:      As(0, Exc_Outl); NextInst;

      case OpOutr:      As(1, Exc_Outr); NextInst;

#undef Var
#undef Is
#undef As

      case OpOrd:
         if (Ptr_(*AP)) *AP = famint_(varianttype_(*AP));  NextInst;

      case OpDestVariant: { locreg_ LWord displ, arg;
         displ = (LWord)(PCWord_);
         if (Ptr_(arg = AP[displ]))
             if (varianttype_(arg) != (PCWord_)) {RaiseExc_(Exc_Bind);}
             else AP[displ] = ((Variant *)(arg)) -> field;
         else
             if (cint_(arg) != PCWord_) {RaiseExc_(Exc_Bind);}
             else AP[displ] = TRIV;
         NextInst; }

      case OpCase: { locreg_ LWord var, x;
         if (Ptr_(var = *AP)) {
            *AP = ((Variant *)(var)) -> field;
            PC += PCSwTab_(varianttype_(var)+1); }
         else {
/*** (Nick) WAS: ***
            *AP = TRIV; PC += PCSwTab_(cint_(var)+1);
 ***  NOW:       ***/
            *AP = TRIV;
            x = cint_(var)+1;
            PC += PCSwTab_(x);
/***             ***/
         }
         NextInst; }

      case OpCaseVal: { locreg_ LWord var;
         if (Ptr_(var = *AP)) *AP = ((Variant *)(var)) -> field;
         else *AP = TRIV;
         NextInst; }

      case OpVariantObject:
         if (*AP == TRIV) AP++;
         else { AllVar_(new_var, *AP, cint_(AP[1])); *(++AP) = (LWord)new_var;}
         NextInst;

      case OpBigVar: /* RJG 10-Mar-89 */
         AllBigVar_(new_bigvar, AP[2], AP[1], *AP); /* arg, num, string */
         AP += 2;  *AP = (LWord)new_bigvar;
         NextInst;

      case OpXConClosure: /* RJG 06-Feb-89 */
         (((Ref *)(*AP)) -> at) = famint_(cint_(((Ref *)(*AP)) -> at) + 1);
         AllClosure_(new_clos, 3); /* text + string + num */
         new_clos -> text = (Text *) XConText;
         global_(new_clos)[0] =  ((Ref *)(*AP)) -> at; /* num */
         global_(new_clos)[1] = *(++AP); /* string */
         *AP = (LWord)new_clos;  NextInst;

      case OpIncRefAt: /* RJG 08-Feb-89 */
         (((Ref *)(*AP)) -> at) = famint_(cint_(((Ref *)(*AP)) -> at) + 1);
         *AP = (((Ref *)(*AP)) -> at); NextInst;

      case OpDestBigVar: { locreg_ LWord displ, arg, pat;
         displ = (LWord)(PCWord_);
         pat = bigvartype_(*AP++);
         if ((Tag_(arg = AP[displ])) == TagBigVar) {
             if (bigvartype_(arg) != pat) {RaiseExc_(Exc_Bind);}
             else AP[displ] = ((BigVar *)(arg)) -> field;}
         else
             if (bigvartype_(arg) != pat) {RaiseExc_(Exc_Bind);}
             else AP[displ] = TRIV;
         NextInst; }

/* added by th and hml for dbm's new ml compiler */
      case OpNotImmed:
         *AP = fambool_(!Immed_(*AP));
         NextInst;

/*<ff>Array primitives */

      case OpArray: { locreg_ LWord len; LWord initval;
         if (BigNum_(len = AP[1]) ||
             (signed_(len = cint_(len)) < 0) ) {RaiseExc_(Exc_Array);}
         AllArray_(new_array, len); initval = *AP++;
         for (len--; signed_(len) >=0; len--) array_(new_array)[len] = initval;
         *AP = (LWord)new_array;
         NextInst; }

      case OpArrayOfList: { locreg_ LWord list, len;
         for (len = 0, list = *AP; list != NIL; len++)
            list = (LWord)tl_(list);
         AllArray_(new_array, len); list = *AP;
         for (len = 0; list != NIL; len++) {
            array_(new_array)[len] = hd_(list);
            list = (LWord)tl_(list); }
         *AP = (LWord)new_array;
         NextInst; }

      case OpSize:
         *AP = famint_(arraylength_(*AP)); NextInst;

      case OpSubscr: { locreg_ LWord offset, arr;
         offset = cint_(*AP++) - 1; arr = *AP;
         if (arraylength_(arr) <= offset) {RaiseExc_(Exc_Subscript);}
         *AP = array_(arr)[offset];
         NextInst; }

      case OpUpdate: { locreg_ LWord newval, offset, *obj; LWord arr;
         newval = *AP++;  offset = cint_(*AP++) - 1; arr = *AP;
         if (arraylength_(arr) <= offset) {RaiseExc_(Exc_Update);}
         array_(arr)[offset] = newval;
         obj=(LWord *)(*AP);
         if ((!(obj[-1] & ASSIGNED)) && ((LWord)obj <= (LWord)EndOfX))
            {EndOfASpace--;
             *EndOfASpace=(LWord)obj;
             obj[-1]=obj[-1] | ASSIGNED;
             if ((LWord)EndOfASpace <= (LWord)MidOfASpace)
                {SaveRegs_; Collect(0); RestoreRegs_;}
            } /* GMK Feb 90. Vector manipulation code. */
         *AP = TRIV;
         NextInst; }
/*AJG <old code>
      case OpUpdate: { locreg_ LWord newval, offset; LWord arr;
         newval = *AP++;  offset = cint_(*AP++) - 1; arr = *AP;
         if (arraylength_(arr) <= offset) {RaiseExc_(Exc_Update);}
         array_(arr)[offset] = newval;  *AP = TRIV;  NextInst; }
*/
      case OpNewSubscr: { locreg_ LWord offset, arr;
         offset = cint_(*AP++); arr = *AP;
         if (arraylength_(arr) <= offset) {RaiseExc_(Exc_Subscript);}
         *AP = array_(arr)[offset];
         NextInst; }

      case OpNewUpdate: { locreg_ LWord newval, offset; LWord arr;
         newval = *AP++;  offset = cint_(*AP++); arr = *AP;
         if (arraylength_(arr) <= offset) {RaiseExc_(Exc_Update);}
         array_(arr)[offset] = newval;  *AP = TRIV;  NextInst; }

/*<ff>Boolean and Jump operations */

/* Operations for the type bool.  Note that the following code should work
 * (in the sense of only giving True or False as results when given them
 * as arguments) whatever the actual values of True and False, provided
 * merely that True has more bits set (and in the same positions) as False.
 * However both values should be immediate and be consistent with the
 * fambool_ macro.
 */

      case OpEq:     { locreg_ LWord arg;
         arg = *AP++;
         *AP = fambool_(CheckEq(arg,*AP));
         NextInst; }

      case OpTrue:   *(--AP) = TRUE_;  NextInst;

      case OpFalse:  *(--AP) = FALSE_; NextInst;

      case OpEqBool: {locreg_ LWord tres;
         tres = (*AP++);  *AP = (*AP ^ tres) ^ TRUE_; NextInst; }

      case OpNot:
         *AP ^= (TRUE_ ^ FALSE_); NextInst;

      case OpAnd: {locreg_ LWord tres;
         tres = *AP++; *AP &= tres; NextInst; }

      case OpOr: {locreg_ LWord tres;
         tres = *AP++; *AP |= tres; NextInst; }



      case OpJumpB: { locreg_ SLWord displ; displ = PCSByte_;
         PC += displ; NextInst; }

      case OpJumpW: { locreg_ SLWord displ; displ = PCSWord_;
         PC += displ; NextInst; }

      case OpTrueJumpB: { locreg_ SLWord displ; displ = PCSByte_;
         if (cbool_(*AP++)) PC += displ;
         NextInst; }

      case OpTrueJumpW: { locreg_ SLWord displ; displ = PCSWord_;
         if (cbool_(*AP++)) PC += displ;
         NextInst; }

      case OpFalseJumpB: { locreg_ SLWord displ; displ = PCSByte_;
         if (!cbool_(*AP++)) PC += displ;
         NextInst; }

      case OpFalseJumpW: { locreg_ SLWord displ; displ = PCSWord_;
         if (!cbool_(*AP++)) PC += displ;
         NextInst; }

      case OpExecute:
#ifdef unix
       { InputStream *inpstr; String *buffer; int pid;
         int pin[2], pout[2]; int child_in, child_out, parent_in, parent_out;
         FAM_FDESC fam_in, fam_out;

         hoststring((String *)(*AP), cworkstring);

         if ((pipe(pin) < 0) || (pipe(pout) < 0))
         {
            perror("pipe");
            RaiseExc_(Exc_Execute);
         }

         child_in = pout[0]; parent_out = pout[1];
         child_out = pin[1]; parent_in = pin[0];

         if ((pid = FORK()) < 0)
         {
            perror("fork/vfork");       /* proper errors? */
            RaiseExc_(Exc_Execute);
         }
         else if (pid == 0)             /* Child */
         {
            close(parent_in); close(parent_out);
            DUP2(child_in, 0);          /* Fix up child's stdin */
            DUP2(child_out, 1);         /* Fix up child's stdout */
/*
 * No virtual alarm facility in non-BSD that I know of...
 *
 * Sam Nelson, Stirling Univ., 20.1.88.
 */
#ifdef BSD
            signal(SIGVTALRM,SIG_IGN);  /* Disable timer signals */
#endif
            execl("/bin/sh", "sh", "-c", cworkstring, 0);
            perror("exec /bin/sh");
            _exit(1);
         }
         signal(SIGPIPE, SIG_IGN);      /* discard pipe signals */

                                        /* Parent */
         close(child_in); close(child_out);
         fam_in = famregstream(parent_in);
         fam_out = famregstream(parent_out);

         AllInputStream_(new_instr);
         *AP = (LWord)new_instr;
         AllString_(new_string,512);
         buffer = new_string;
         inpstr = (InputStream *)(*AP);
         inpstr->fid = famint_(fam_in); inpstr->buffer = buffer;
         inpstr->len = famint_(0); inpstr->pos = famint_(0);
         inpstr->next = (LWord *)CurrentState->ActiveStreams;
         CurrentState->ActiveStreams = (Cons *)(inpstr);

         AllCons_(new_cons, famint_(fam_out), CurrentState->ActiveStreams);
         *(--AP) = (LWord)((CurrentState->ActiveStreams) = new_cons);
         AllPair_(new_pair, AP[1], *AP); *(++AP) = (LWord)new_pair;
         NextInst; }
#else
         RaiseExc_(Exc_Execute);
#endif  /* unix */

/*<ff>Function primitives */

      case OpBind: PC++; NextInst;

      case OpClosure: { locreg_ LWord gptr; LWord size;
         size = PCWord_;
         AllClosure_(new_clos, size);
         new_clos -> text = (Text *)(*AP++);
         for (gptr=0; gptr < (size-1); gptr++) global_(new_clos)[gptr] = *AP++;
         *(--AP) = (LWord)new_clos;  NextInst; }

      case OpClosure1:
         AllArray_(new_array,2);
         ((LWord *)new_array)[0] = *AP;
         ((LWord *)new_array)[1] = AP[1];
         *(++AP) = (LWord)new_array; NextInst;

      case OpDumClosure: { locreg_ LWord size;
         size = PCWord_;
         AllClosure_(new_clos, size);
         new_clos -> text = NIL;
         for(size-=2; signed_(size) >= 0; size--) global_(new_clos)[size] = NIL;
         *(--AP) = (LWord)new_clos;
         NextInst; }

      case OpDumClosure1:
         AllRec2_(new_recN, NIL,NIL); *(--AP) = (LWord)new_recN; NextInst;

      case OpRecClosure: { locreg_ LWord size, clos; LWord gptr;
         size = PCWord_;  clos = AP[PCWord_];
         ((Closure *)clos) -> text = (Text *)(*AP++);
         for (gptr=0; gptr < (size-1); gptr++) global_(clos)[gptr] = *AP++;
         NextInst; }

      case OpPop:       AP += PCWord_; NextInst;

      case OpSqueezeB: { locreg_ LWord amount;
         amount = *PC++;  AP[amount] = *AP;  AP += amount;  NextInst; }
      case OpSqueezeW: { locreg_ LWord amount;
         amount = PCWord_;  AP[amount] = *AP;  AP += amount;  NextInst; }
      case OpSqueeze1:  Squeeze1_(AP);  NextInst;

      case OpSlideB: { locreg_ LWord stkpos, cnt;
         stkpos  = (LWord)&(AP[*PC++]);
         for (cnt  = *PC++; signed_(cnt) >= 0; cnt--)
             ((LWord *) stkpos)[cnt] = AP[cnt];
         AP = (LWord *)stkpos;  NextInst; }

      case OpSlideW: { locreg_ LWord stkpos, cnt;
         stkpos  = (LWord)&(AP[PCWord_]);
         for (cnt  = PCWord_; signed_(cnt) >= 0; cnt--)
             ((LWord *) stkpos)[cnt] = AP[cnt];
         AP = (LWord *)stkpos;  NextInst; }

      case OpReturn: { locreg_ LWord displ;
         displ = *PC;
         AP[displ] = *AP; AP += displ;
#ifdef NATIVE
                       if(Ptr_(CP[0])){
                         PC = (Byte *) *CP++;
                         NEXTINNC
                         }
#endif
         PC = (Byte *)IPtrOff_(((Closure *)(CP[1])) -> text, CP[0]);
         CP++; NextInst; }

      case OpReturn0:
#ifdef NATIVE
         if(Ptr_(CP[0])){
           PC = (Byte *) *CP++;
           NEXTINNC
           }
#endif
         PC = (Byte *)IPtrOff_(((Closure *)(CP[1])) -> text, CP[0]);
         CP++; NextInst;

      case OpReturn1:
         Squeeze1_(AP);
#ifdef NATIVE
         if(Ptr_(CP[0])){
           PC = (Byte *) *CP++;
           NEXTINNC
           }
#endif
         PC = (Byte *)IPtrOff_(((Closure *)(CP[1])) -> text, CP[0]);
         CP++; NextInst;

      case OpSaveFrame:  *(--CP) = (LWord)FP; NextInst;

      case OpApplFrame:
         /* the next four lines should use the values from the text
            when the compiler sets them correctly */
         if (signed_(PtrDiff_(AP,CurrentProcess->ArgStk)) < 500)
            {RaiseExc_(Exc_ArgStkOvfl);}
         if (signed_(PtrDiff_(CP,CurrentProcess->CtlStk)) < 500)
            {RaiseExc_(Exc_CtlStkOvfl);}
         FP = (Closure *)(*AP++);
         OrdAssign_(*(--CP), IPtrDiff_(((Closure *)*CP) -> text,PC));
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
         PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;

      case OpRestFrame:  FP = (Closure *)(*CP++);
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
         NextInst;

      case OpTailApplyB: { locreg_ LWord offset, args;
         FP = (Closure *)(*AP++);
         offset = (LWord)(AP + *PC++);
         for (args=(LWord)(*PC++); signed_(args) >= 0; args--)
            ((LWord *)offset)[args] = AP[args];
         AP = (LWord *)offset;
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
           PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;
                         }

      case OpTailApplyW: { locreg_ LWord offset, args;
         FP = (Closure *)(*AP++);
         offset = (LWord)(AP + PCWord_);
         for (args=(LWord)PCSWord_; signed_(args) >= 0; args--)
            ((LWord *)offset)[args] = AP[args];
         AP = (LWord *)offset;
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
           PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;
                         }

      case OpTailApply_n0:
         FP = (Closure *)(*AP++);
         AP += PCWord_;
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
   PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;

      case OpTailApply_n1: { locreg_ LWord offset;
         FP = (Closure *)(*AP++);
         offset = *PC;  AP[offset] = *AP;  AP += offset;
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
   PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;
                           }

      case OpTailApply_0n:
         FP = (Closure *)(*AP++);
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
   PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;

      case OpTailApply_11:
         FP = (Closure *)(*AP++);
         Squeeze1_(AP);
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
   PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;

      case OpDestTailApply: { locreg_ LWord size, cnt; LWord rec;
         /* Equivalent to [DestTuple n, 0; GetFree 1; TailApply n, 0] */
         size = *PC++; rec = *AP++;
         for (cnt=0; cnt<size; cnt++) *(--AP) = rec_(rec)[cnt];
         FP = (Closure *)(*(global_(FP)));
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
#ifdef NATIVE
         PC = ((Byte *)&((FP -> text) -> PhiBC));
         if ((PCWord_) == NCTAG) { /* like src switching from BC */
           NEXTINNC
           }
#else
   PC = ((Byte *)&((FP -> text) -> firstbyte));
#endif
           NextInst;

                            }

      case OpFunId:   *(--AP) = (LWord)FunIdClos;  NextInst;

      case OpFunComp:
         AllClosure_(new_clos, 3);
         new_clos -> text = FunCompText;
         global_(new_clos)[0] = *AP++;
         global_(new_clos)[1] = *AP++;
         *(--AP) = (LWord)new_clos; NextInst;

/*******************************************************************/
/*        Native Code Stuff, AJG: 25/6/91 , honours project        */
/*******************************************************************/

/* these two functions are related to castling */

#ifdef NATIVE
#ifdef CASTLING_LATER
      case OpOldText:{
        Text *nc_text;
        Literals *lits;
        LWord size;

        lits = (FP -> text) -> literals;
        size = (literalslength_(lits))-1;
        nc_text = (Text *) literal_(lits)[size];
        FP -> text = nc_text; /* castled !!! */
        PC = ((Byte *)&((FP -> text) -> PhiBC));
        NEXTINNC;
        }

     case OpReplaceText: {
        Text *bc_text,*nc_text;
        Literals *old_lits;
        LWord  size,cnt;

        /* pull in the texts */

        nc_text =  (Text *) *AP++;
        bc_text =  (Text *) *AP;

        old_lits = bc_text -> literals;
        size = literalslength_(old_lits)+1;

        /* allocate a new literal block with an extra pointer */

        AllRecN_(new_recN, size);
         for (cnt=size-1; signed_(cnt)>=0; cnt--)
           rec_(new_recN)[cnt] = rec_(old_lits)[cnt];  /* copy everything */

        rec_(new_recN)[size-1] = (LWord) nc_text;
        bc_text->literals = (Literals *)new_recN;

        bc_text->firstbyte = OpOldText; /* 113: the magic number ... */
/*      bc_text->ProfileVal = -1; */ /* dont look at this again ... */

         *AP = INTZERO; NextInst; }
#endif

/***************************************************************/
/* This is a PhiNC switch. The next instruction must be in NC  */

       case OpBCtoNC:
            NEXTINNC    /* this is \Phi NC */

/***************************************************************/
/* This is a PhiBC switch. The next instruction must be in BC  */

RTSHANDLER          /* The Run time system return pointer */
  NEXTINBC          /* this is \Phi BC */

/*************************************************************/
/*
 *             This lets NC raise a built-in Exception
 */

       case OpNCraise: RaiseExc_(*AP++);

/*************************************************************/
#endif

       case OpVetText: /* Text -> int */
           {
             Text *tmptext;
             Word tmpreg;

             tmptext = (Text *) *AP;

     /* not a text pointer */

             if (!tmptext) { *AP = INTZERO ; NextInst; }

             tmpreg = tmptext -> PhiBC;

     /* already in NC, so dont recompile !!! */
             if(((tmpreg)) != BCTAG){
               *AP = INTZERO ; NextInst;
             }

             if(tmptext -> firstbyte == OpOldText){  /* going to change */
               *AP = INTZERO ; NextInst;
             }
             if(tmptext -> ProfileVal < 0){   /* dont consider ... */
               *AP = INTZERO ; NextInst;
             }
     /* ok to proceed, so all go for NC ... */

             *AP = famint_(tmptext->ProfileVal);  /* the funs popularity */
             NextInst;
           }

/*************************************************************/
/*
 *       Export a hook into the compiler
 */

       case OpProfHook:
         AllRef_(new_ref,0);
         CurrentState -> ProfRef = (Ref *) new_ref;
         *AP = (LWord)new_ref;
         NextInst;

/*******************************************************************/



/*<ff>Integer operations */
      case OpByteNum:
         *(--AP) = famint_(*PC++); NextInst;

      case OpInt:  *(--AP) = famint_(PCLWord_); NextInst;

      case OpDestInt: { locreg_ LWord arg1, arg2;
         arg1 = *AP++; arg2 = AP[PCWord_];
         if (arg1 != arg2) {RaiseExc_(Exc_Bind);}
         NextInst; }

#define IDiad(FUNC)                                                \
         arg2 = *AP++;                                             \
         arg1 = *AP++;                                             \
         SaveRegs_;                                                \
         arg1 = FUNC(arg1, arg2);                                  \
         RestoreRegs_;                                             \
         *--AP = arg1;

      case OpPlus:   {locreg_ LWord arg1, arg2; IDiad(GenericPLUS); NextInst; }

      case OpDiff:   {locreg_ LWord arg1, arg2; IDiad(GenericMINUS); NextInst; }

      case OpTimes:  {locreg_ LWord arg1, arg2; IDiad(GenericTIMES); NextInst; }

      case OpDivide:
      case OpIntDiv:
#ifdef selport /* The stupid Gould C compiler is at it again */
                     if (*AP == IntZero) {RaiseExc_(Exc_Div);}
#else
                     if (*AP == INTZERO) {RaiseExc_(Exc_Div);}
#endif
                     {locreg_ LWord arg1, arg2;
                      IDiad(GenericDIV);
                      NextInst;
                     }

      case OpMod:
#ifdef selport /* and again ... */
                     if (*AP == IntZero) {RaiseExc_(Exc_Mod);}
#else
                     if (*AP == INTZERO) {RaiseExc_(Exc_Mod);}
#endif
                     {locreg_ LWord arg1, arg2;
                      IDiad(GenericMOD);
                      NextInst;
                     }

      case OpNeg:
         {locreg_ LWord arg1;
          arg1 = *AP++;
          SaveRegs_;
          arg1 = GenericNEG(arg1);
          RestoreRegs_;
          *--AP = arg1;
          NextInst;}

/* Evaluation of relational ops can not provoke garbage collection */
#define IRelop(OP)                                                       \
         arg2 = *AP++;                                                   \
         *AP = fambool_(OP(*AP, arg2))

      case OpEqInt:   {locreg_ LWord arg2; IRelop(GenericEQ); NextInst; }

      case OpGreater: {locreg_ LWord arg2; IRelop(GenericGT); NextInst; }

      case OpLess:    {locreg_ LWord arg2; IRelop(GenericLT); NextInst; }

      case OpGreatEq: {locreg_ LWord arg2; IRelop(GenericGE); NextInst; }

      case OpLessEq:  {locreg_ LWord arg2; IRelop(GenericLE); NextInst; }


/*<ff>Real operations */
/* RISC_OS
 * faster to catch F.P. exceptions by hand than bother with *
 * setting up a longjmp to allow return from signal         */

#define FDiad(OP) { AllReal_(new_real, real_(AP[1]) OP real_(*AP));  \
                    *(++AP) = (LWord)new_real; }

#define FUpDiad(OP) tmp = real_(*AP++); real_(*AP) = real_(*AP) OP tmp;

#define FMonad(OP) { AllReal_(new_real, OP(real_(*AP)));  \
                     *AP = (LWord)new_real; }

#define FRelop(OP) tmp = *AP++; *AP = fambool_(real_(*AP) OP real_(tmp));

      case OpFPlus:   FDiad(+); NextInst;

      case OpFDiff:   FDiad(-); NextInst;

      case OpFTimes:  FDiad(*); NextInst;

      case OpFDivide: FDiad(/); NextInst;

      case OpFUpPlus:   {locreg_ double tmp; FUpDiad(+); NextInst; }
      case OpFUpDiff:   {locreg_ double tmp; FUpDiad(-); NextInst; }
      case OpFUpTimes:  {locreg_ double tmp; FUpDiad(*); NextInst; }
      case OpFUpDivide: {locreg_ double tmp; FUpDiad(/); NextInst; }

      case OpFNeg:    FMonad(-); NextInst;

      case OpSqrt:    FMonad(sqrt); if (errno==EDOM)
                                      { errno=0; RaiseExc_(Exc_Sqrt); }
                      NextInst;
      case OpSin:     FMonad(sin); NextInst;
      case OpCos:     FMonad(cos); NextInst;
      case OpArctan:  FMonad(atan); NextInst;
      case OpExp:     FMonad(exp); if (errno==ERANGE)
                                     { errno=0; RaiseExc_(Exc_Exp); }
                      NextInst;
      case OpLn:      FMonad(log); if (errno==EDOM)
                                     { errno=0; RaiseExc_(Exc_Ln); }
                      NextInst;

      case OpFEql:    {locreg_ LWord tmp; FRelop(==); NextInst; }

      case OpFLss:    {locreg_ LWord tmp; FRelop(<); NextInst; }

      case OpFGtr:    {locreg_ LWord tmp; FRelop(>); NextInst; }

      case OpFGeq:    {locreg_ LWord tmp; FRelop(>=); NextInst; }

      case OpFLeq:    {locreg_ LWord tmp; FRelop(<=); NextInst; }

      case OpRealOfString: {int i;
         hoststring((String *)(*AP), cworkstring);
         for (i=stringlength_(*AP)-1; i >= 0; i--)
            if (cworkstring[i] == '~') cworkstring[i] = '-';
         AllReal_(new_real, 0.0);
         if (sscanf(cworkstring, "%lf", &real_(new_real)) != 1)
            {RaiseExc_(Exc_RealOfString);}
         *AP = (LWord)new_real;
         NextInst; }

      case OpReal:
         {   double r = GenericREAL(*AP);
             if (GenericRC) {RaiseExc_(Exc_Real);}
             AllReal_(new_real, r);
         }
         *AP = (LWord)new_real;
         NextInst;

      case OpFloor: {
         locreg_ double R; LWord w;
         R = real_(*AP);
         SaveRegs_;
         w = GenericFLOOR(R);
         RestoreRegs_;
         *AP = w;
         if (GenericRC) { errno=0; RaiseExc_(Exc_Floor);}
         NextInst;
       }

      case OpStringOfReal:
         stringofreal(cworkstring, real_(*AP));
         AllString_(new_string, strlen(cworkstring));
         famstring(new_string, cworkstring);
         *AP = (LWord)new_string;
         NextInst;


      case OpDestReal:  {locreg_ double r;
         r = real_(*AP++);
         if (r != real_(AP[PCWord_]))  { RaiseExc_(Exc_Bind); }
         NextInst; }


/*<ff>List operations */

      case OpTuple_0:  *(--AP) = NIL;  NextInst;

      case OpDestNil:
         if ( AP[PCWord_] != NIL )  {RaiseExc_(Exc_Bind);}
         NextInst;

      case OpDestQCons:
         if (AP[PCWord_] == NIL)  {RaiseExc_(Exc_Bind);}
         NextInst;

      case OpHd: { locreg_ LWord list;
         if ((list = *AP) == NIL) {RaiseExc_(Exc_Hd);}
         *AP = hd_(list); NextInst; }

      case OpTl: { locreg_ LWord list;
         if ((list = *AP) == NIL) {RaiseExc_(Exc_Tl);}
         *AP = (LWord)tl_(list); NextInst; }

      case OpNull:
         *AP = fambool_(*AP == NIL);
         NextInst;

     case OpListLength: { locreg_ LWord len, list;
         len = INTZERO;
         for (list = *AP; list != NIL; list=(LWord)tl_(list), len++);
         *AP = len; NextInst; }

      case OpNth: { locreg_ LWord pos, list;
         for (pos = cint_(*AP++), list = *AP;
              (signed_(pos) > 1) && (list != NIL);
              pos--, list = (LWord)tl_(list));
         if ((pos == 1) && (list != NIL)) {*AP = hd_(list); }
         else {RaiseExc_(Exc_Nth);}
         NextInst; }

      case OpRev:
         if (*AP == NIL) NextInst;
         *(--AP) = NIL;
         do {AllCons_(new_cons, hd_(AP[1]),*AP); *AP = (LWord)new_cons; }
         while ((AP[1] = (LWord)tl_(AP[1])) != NIL);
         Squeeze1_(AP); NextInst;

      case OpTupleOfList: { locreg_ LWord list, len;
         if ((list = *AP) == NIL) NextInst;
         for (len=0; list != NIL; (list = (LWord)tl_(list), len++));
         if (len > 2) { AllRecN_(new_recN, len); }
         else if (len == 2) { AllRec2_(new_recN, 0, 0); }
         else if (len == 1) { AllRec1_(new_recN, 0); }
         else { AllRecN_(new_recN, len); }
         list = *AP;
         for (len = 0; list != NIL;
              rec_(new_recN)[len] = hd_(list), list = (LWord)tl_(list), len++);
         *AP = (LWord)new_recN;
         NextInst; }


/*<ff>Printing primitives */

      case OpPrintNull: printf("()"); *AP = TRIV; NextInst;

      case OpPrintBool:
         printf(cbool_(*AP) ? "true" : "false"); NextInst;

      case OpPrintInt:
         GenericPRINT(*AP);
         NextInst;

      case OpPrintReal:
         stringofreal(cworkstring, real_(*AP));
         printf("%s",cworkstring); NextInst;

      case OpPrintString: { locreg_ LWord ch, cptr; LWord len, str = *AP;
         len = stringlength_(str);
         putchar('"');
         for (cptr = 0; cptr < len; cptr++) {
            ch = stringchar_(str)[cptr];
            if (ch < asciichar(' '))
               printf("\\^%c", hostchar((char)ch+asciichar('@')));
            else if ( (ch==asciichar('\\')) || (ch==asciichar('"')) )
               printf("\\%c", hostchar((char)ch));
            else putchar(hostchar((char)ch)); }
         putchar('"'); NextInst; }

/* PrintADT and MkPlot are for the support of A C Norman graphics */
      case OpPrintADT:
          printADT(*AP);
          NextInst;

      case OpMkPlot:
          Tag_(*AP) = TagPlot;
          NextInst;

      case OpBpt:
      case OpOutString: {
         foutstring(stringchar_(*AP), stringlength_(*AP));
         NextInst; }

      case OpFlush: {
         fflush(stdout); *(--AP) = NIL;
         NextInst; }

      case OpPrompt: {
/* save the prompt for readline, or output and flush it */
#ifdef READLINE
         int w = min(stringlength_(*AP),PROMPTWIDTH-1);
         (void) strncpy(rl_fam_prompt, stringchar_(*AP), w);
         rl_fam_prompt[w+1] = (char) 0x0;
#else
#ifdef CWIN
         {   char *p = stringchar_(*AP);
             int n = stringlength_(*AP), c;
/*
 * The hackery here is to try to avoid prompts getting included when
 * the user does a CUT or COPY. It is based JUST on the prompts "- "
 * and "= " used by the regular ML top-level.
 */
             if (n == 2 && p[0] == '-' && p[1] == ' ')
                 cwin_putchar(0x81), cwin_putchar(0x80);
             else if (n == 2 && p[0] == '=' && p[1] == ' ')
                 cwin_putchar(0x82), cwin_putchar(0x80);
             else foutstring(p, n);
             cwin_ensure_screen();
         }
#else
         foutstring(stringchar_(*AP), stringlength_(*AP));
         fflush(stdout);
#endif
#endif
         *AP = NIL;
         NextInst; }


      case OpPrintObj: {
         if (Immed_(*AP)) {
           printf("immediate");
         }
         else switch (Tag_(*AP)) {
           case TagState:  printf("state"); break;
           case TagProcess:printf("process"); break;
           case TagRec1:
           case TagUpRec1: printf("rec1"); break;
           case TagRec2:
           case TagUpRec2: printf("rec2"); break;
           case TagRecN:
           case TagUpRecN: printf("recN"); break;
           case TagString: printf("string"); break;
           case TagReal:   printf("real"); break;
           case TagVariant:printf("variant"); break;
           case TagBigVar: printf("bigvar"); break;
           case TagText:   printf("text"); break;
           case TagStack:  printf("stack"); break;
           default:  printf("unknown"); break;
         }
         printf(" 0x%lx",*AP);
         NextInst; }

/*<ff>Record primitives */

      case OpTuple_2:
         AllPair_(new_pair, AP[1],*AP); *(++AP) = (LWord)new_pair; NextInst;

      case OpTuple: { locreg_ LWord size, cnt;
         size = PCWord_;
         AllRecN_(new_recN, size);
         for (cnt=size-1; signed_(cnt)>=0; cnt--) rec_(new_recN)[cnt] = *AP++;
         *(--AP) = (LWord)new_recN; NextInst; }

      case OpQuaDot:  *AP = rec_(*AP)[PCWord_];  NextInst;

      case OpFst:     *AP = fst_(*AP);  NextInst;

      case OpSnd:     *AP = snd_(*AP);  NextInst;

      case OpObjComp: { locreg_ LWord pos;
         pos = cint_(*AP++); *AP = rec_(*AP)[pos]; NextInst; }

      case OpDestTuple: { locreg_ LWord size, cnt; LWord rec, displ;
         size = PCWord_; displ= PCWord_; rec = AP[displ];
         AP[displ] = rec_(rec)[0];
         for (cnt=1; cnt<size; cnt++) *(--AP) = rec_(rec)[cnt];
         NextInst; }

      case OpDestTuple_n0: { locreg_ LWord size, cnt; LWord rec;
         size = PCWord_; rec = *AP++;
         for (cnt=0; cnt<size; cnt++) *(--AP) = rec_(rec)[cnt];
         NextInst; }

      case OpDestTuple_20: { locreg_ LWord rec;
         rec = *AP; *AP = rec_(rec)[0]; *(--AP) = rec_(rec)[1]; NextInst; }


/*<ff>Process primitives */

      case OpCurrentState:   *(--AP) = (LWord)CurrentState; NextInst;
      case OpCurrentProcess: *(--AP) = (LWord)CurrentProcess; NextInst;

      case OpSuspendProcess:
         CurrentProcess->Flags |= Process_Suspended;
         goto suspstop;

      case OpStopProcess: { Process *father;
         CurrentProcess->Flags |= Process_Terminated;

suspstop:CurrentProcess->Flags &= ~Process_Active;
         if ((father=CurrentProcess->Father) == 0) goto removeprocess;
         if (((--father->NumSons) == 0) &&
             (father->Flags & Process_WaitingForSons)) {
            father->Flags &= ~Process_WaitingForSons;
            if (CurrentProcess->Next == CurrentProcess)
               CurrentState->WaitingLastProc = father;
            father->Next = CurrentProcess->Next;
            CurrentProcess->Next = father; }

         if ((father->Flags & Process_WaitingForSon) &&
             (father->WaitingFor == CurrentProcess)) {
            father->Flags &= ~Process_WaitingForSon;
            father->WaitingFor = 0;
            if (CurrentProcess->Next == CurrentProcess)
               CurrentState->WaitingLastProc = father;
            father->Next = CurrentProcess->Next;
            CurrentProcess->Next = father; }

         goto removeprocess; }


      case OpNewProcess:  { Process *newproc; LWord stksize; Stack *newstk;
                            LWord *temp;
         AllProcess_(new_proc);
         new_proc -> Next = (Process *)0;
         new_proc -> ArgStk = 0;
         new_proc -> CtlStk = 0;
         new_proc -> Frame = StartupClosure;  new_proc -> PC = 8; /*AJG :-) */
         new_proc -> EnvDead = (Pair *)0;
         new_proc -> Father = (Process *)0;
         new_proc -> WaitingFor = (Process *)0;
         new_proc -> Flags = 0;
         new_proc -> NumSons = 0;
         new_proc -> CtrlCEnabled = 0;
         *--AP = (LWord)new_proc;
         stksize = cint_(AP[2]); AllStack_(new_stack, stksize);
         ((Process *)(*AP)) -> ArgStk = new_stack;
         stksize = cint_(AP[1]); AllStack_(new_stack, stksize);
         ((Process *)(*AP)) -> CtlStk = new_stack;
         newproc = (Process *)(*(AP++)); AP += 2;
         newstk = newproc -> ArgStk;
         temp = StackPointer(newstk);
         *(--temp) = 0;
         *(--temp) = (LWord)*AP;
         (newstk -> StkPos) = PtrDiff_(temp, newstk);
         *AP = (LWord)newproc; NextInst; }


      case OpNewState: { LWord list; Process *lastproc;  int textsize;
         AllState_(new_state);
         *new_state = *CurrentState;

         if (*AP == 0) lastproc = 0; else lastproc = (Process *)hd_(*AP);

         new_state->WaitingProcesses = new_state->WaitingLastProc = lastproc;

         for (list = *AP; list != NIL; list = (LWord)tl_(list)) {
             ((Process *)hd_(list)) -> Next = new_state -> WaitingProcesses;
             new_state -> WaitingProcesses = (Process *)hd_(list); }

         lastproc -> Next = new_state -> WaitingProcesses;
/*
 * changes to built in texts occur here
 *************************************
  *(--AP) = (LWord) new_state;
/# XConText code left here for documentation
  textsize = 5; /# 5 bytes #/
  AllText_(new_text, textsize+(sizeof(LWord)*2)); /# use 3 #/
  new_text->CtlSpaceReq = 10; /# 0 would do #/
  new_text->ArgSpaceReq = 10; /# 1 would do #/
  new_text->literals = NIL;   /# Can't fail - no name field! #/

  /# now store bytes #/
  *(Byte *)(bytecode_(new_text) + 0) = OpGetFree1; /# number #/
  *(Byte *)(bytecode_(new_text) + 1) = OpGetFreeB; /# string #/
  *(Byte *)(bytecode_(new_text) + 2) = (Byte) 2;   /#        is 2nd free #/
  *(Byte *)(bytecode_(new_text) + 3) = OpBigVar;   /# OpBigVar #/
  *(Byte *)(bytecode_(new_text) + 4) = OpReturn0;  /# Return0  #/

/# FunCompText code - left here for documentation #/
  AllString_(new_string, 1);  /# function name #/
  stringchar_(new_string)[0] = 'o';
  *(--AP) = (LWord) new_string; /#push onto stack#/
  AllRec1_(new_recN,0);
  rec_(new_recN)[0] = *AP++;
  *(--AP) = (LWord) new_recN; /#push onto stack#/

  textsize = 7; /# 7 bytes #/
  AllText_(new_text, textsize+(sizeof(LWord)*2));  /# use 3 #/
  new_text->CtlSpaceReq = 1;
  new_text->ArgSpaceReq = 1;
  new_text->literals = (Literals *) *AP++; /# plant string here #/

  /# now store bytes #/
  *(Byte *)(bytecode_(new_text) + 0) = OpGetFree1; /# fun1 #/
  *(Byte *)(bytecode_(new_text) + 1) = OpSaveFrame;
  *(Byte *)(bytecode_(new_text) + 2) = OpApplFrame;
  *(Byte *)(bytecode_(new_text) + 3) = OpRestFrame;
  *(Byte *)(bytecode_(new_text) + 4) = OpGetFreeB; /# fun2 #/
  *(Byte *)(bytecode_(new_text) + 5) = (Byte) 2; /# free 2 #/
  *(Byte *)(bytecode_(new_text) + 6) = OpTailApply_0n;

  tmpstate = (State *) *AP++;
  tmpstate->FunCompText = new_text;
**************************************
* end of text changes */

         *AP = (LWord)new_state;  NextInst; }

      case OpSmashProcess:   printf("OpSmashProcess\n"); prompt(); NextInst;

      case OpSmashState:
         SaveRegs_; SaveProcessState();
         CurrentState = (State *)(*AP);   (*AP) = TRIV;
         SetTopProcess(); RestoreProcessState(); RestoreRegs_; NextInst;

      case OpExportCurrentState: {
         SaveRegs_; SpecialCollect(0); RestoreRegs_;
         hoststring((String *)(*AP), cworkstring);
         (*AP) = FALSE_;  SaveRegs_; SaveProcessState();
         ExportState(cworkstring,0,NIL); RestoreProcessState(); RestoreRegs_;
         (*AP) = TRUE_;   NextInst; }

      case OpExport: { LWord *obj, *size;
         obj = (LWord *)(*AP++);
         SaveRegs_; size = ObjCollect(obj); RestoreRegs_;
         if (size == NIL) {RaiseExc_(Exc_Export);}
         hoststring((String *)(*AP), cworkstring);
         (*AP) = FALSE_;  SaveRegs_; SaveProcessState();
         ExportState(cworkstring,0,size); RestoreProcessState(); RestoreRegs_;
         (*AP) = TRUE_;   NextInst; }

      case OpImport: { LWord *obj;
         hoststring((String *)(*AP), cworkstring);
         SaveRegs_; SaveProcessState();
         obj = ImportState(cworkstring,1,0);
         RestoreProcessState(); RestoreRegs_;
         (*AP) = (LWord)obj;   NextInst; }

      case OpSpawnProcess: { int owner; Process *sproc;
         owner = cbool_(*AP++); sproc = (Process *)(*AP);
         if (sproc->Flags & Process_Terminated) {RaiseExc_(Exc_ProcTerm);}
         if (sproc->Flags & Process_Active) {RaiseExc_(Exc_ProcActive);}
         sproc->Flags |= Process_Active;
         sproc->Next = CurrentProcess->Next;  CurrentProcess->Next = sproc;
         if (CurrentState->WaitingLastProc == CurrentProcess)
            CurrentState->WaitingLastProc = sproc;
         if (owner) sproc->Father = CurrentProcess;
         else sproc->Father = CurrentProcess->Father;
         if (sproc->Father != 0) sproc->Father->NumSons++;
         (*AP) = TRIV; NextInst; }

      case OpRescheduleProcess:
         SaveRegs_; SaveProcessState(); goto scheduleproc;

      case OpWaitForProcesses: { Process *sproc;
         if ((sproc = CurrentProcess)->NumSons == 0) NextInst;
         sproc->Flags |= Process_WaitingForSons;
         goto removeprocess; }

      case OpWaitForProcess: { Process *sproc;
         if ((sproc = (Process *)(*AP))->Father != CurrentProcess)
            {RaiseExc_(Exc_ProcNotOwner);};
         if (sproc->Flags & (Process_Terminated | Process_Suspended))
            {NextInst;}
         CurrentProcess->Flags |= Process_WaitingForSon;
         CurrentProcess->WaitingFor = sproc;

removeprocess:
         SaveRegs_; SaveProcessState();
         if (CurrentProcess->Next == CurrentProcess) {
            if (CurrentState->SuspendedProcesses == 0) { Process *father;
               if (((father=CurrentProcess->Father) != 0) &&
                   (father->Flags & ( Process_Suspended
                                    | Process_WaitingForSon
                                    | Process_WaitingForSons))) {
                  CurrentState->WaitingLastProc =CurrentProcess->Next = father;
                  father->Flags &= ~(Process_WaitingForSon | Process_Suspended
                                     | Process_WaitingForSons);
                  }
               else ExitML; }
            else { Process *p;
               p = CurrentProcess->Next = CurrentState->SuspendedProcesses;
               while (p->Next != 0) { p->Flags = 0; p = p->Next; }
               p->Flags=0;
               CurrentState->WaitingLastProc = p;
               CurrentState->SuspendedProcesses = 0; } }

         tempproc = CurrentProcess;
         CurrentState->WaitingLastProc->Next = CurrentProcess =
         CurrentState->WaitingProcesses = CurrentProcess->Next;

         if (Suspending) {
            if (CurrentState->SuspendedProcesses != 0) {
               tempproc->Next = CurrentState->SuspendedProcesses; }
            else { tempproc->Next = 0; }
            CurrentState->SuspendedProcesses = tempproc;
            Suspending = 0; }

         goto scheduleproc; }

      case OpSynchronise: { Cons *next; LWord *request, port, porttype;
                            Process *mproc; LWord reqtype, mque, q, nxtport,
                            mreq, i, cont, mcont;
                            Pair *res, *mres; Stack *mstk;

         if (*AP == 0) { /* No requests */
            CurrentProcess->Flags |= Process_Terminated;
            goto suspstop; }

         for (next = (Cons *)(*AP); next != NIL; next = tl_(next)) {
            request = (LWord *)(hd_(next));
            port = fst_(request); porttype = cint_(fst_(port));

            if (porttype == 1) continue; /* empty case */
            if (porttype == 0) break;    /* both case  */
            if ((varianttype_(snd_(request))+2) == porttype) continue;
            porttype = 0; break; }

         if (porttype == 0) { /* then we have found a match */
            *(--AP) = (LWord)port; *(--AP) = (LWord)request;
            AllPair_(new_pair, 0,0); *(--AP) = (LWord)new_pair;
            AllPair_(new_pair, 0,0); mres = new_pair;
            res = (Pair *)(*AP++);
            request = (LWord *)(*AP++); port = *AP++;

            mproc = (Process *)hd_(snd_(port));
            reqtype = varianttype_(snd_(request));
            mstk = mproc -> ArgStk;
            mque = *StackPointer(mstk);

            /* Withdraw offers and find matching request */
            for (q = mque; q != NIL; q = (LWord)tl_(q)) {
               i = nxtport = fst_(hd_(q));
               if ((nxtport == port)
               &&  (reqtype != varianttype_(snd_(hd_(q))))) mreq = hd_(q);
               while (hd_(snd_(i)) != (LWord)mproc) { i = snd_(i); }
               snd_(i) = snd_(snd_(i));
               if (snd_(nxtport) == 0) fst_(nxtport) = famint_(1); }

            /* fix up results */
            cont = ((Variant *)snd_(request))->field;
            mcont = ((Variant *)snd_(mreq))->field;
            if (varianttype_(snd_(request)) == 0) { /* I am an input request */
               fst_(res) = cont; snd_(res) = fst_(mcont);
               fst_(mres) = snd_(mcont); snd_(mres) = NIL; }
            else { /* I am an output request */
               fst_(res) = snd_(cont); snd_(res) = NIL;
               fst_(mres) = mcont; snd_(mres) = fst_(cont); }

            *StackPointer(mstk) = (LWord)mres;
            *AP = (LWord)res;
            mproc->Next = CurrentProcess->Next;
            CurrentProcess->Next = mproc;
            SaveRegs_; SaveProcessState();
            goto scheduleproc;
            }

         else { /* we must wait ... */
            for (next = (Cons *)(*AP); next != NIL; next = tl_(next)) {
               request = (LWord *)(hd_(next));
               reqtype = varianttype_(snd_(request));
               port = fst_(request); porttype = cint_(fst_(port));
               if (porttype == 1) fst_(port) = famint_(reqtype+2);
               else if (porttype == 0) ;
               else if ((reqtype+2) != porttype) fst_(port) = famint_(0);
               AllCons_(new_cons, CurrentProcess,NIL);
               if (snd_(port) == NIL) snd_(port) = (LWord)new_cons;
               else {
                  for (i=snd_(port); tl_(i) != NIL; i = (LWord)tl_(i)) ;
                  tl_(i) = new_cons; }
               }
            goto removeprocess;
            }
         }


      case OpRandomMerge:
         printf("OpRandomMerge\n"); prompt(); NextInst;



/*<ff>Assorted junk */

      case OpNoOp: NextInst;

      case OpCollect: SaveRegs_; Collect(0); RestoreRegs_; NextInst;

      case OpSpecialCollect: SaveRegs_; SpecialCollect(0); RestoreRegs_;
         NextInst;  /* GMK Nov 89. To allow manual calling of */
                    /* special collections.                   */

      case OpCpuTime: *(--AP) = famint_(TimeInMS()); NextInst;

      case OpGetEnv: { int i; char *s, *res;
         hoststring((String *)(*AP), cworkstring);
         res = (char *)getenv(cworkstring);
         if (res == 0) {AllString_(new_string,0); *AP = (LWord)new_string;}
         else {
           AllString_(new_string,strlen(res));
           *AP = (LWord)new_string; s = stringchar_(*AP);
           for (i=strlen(res)-1; i >= 0; i--) s[i] = res[i]; }
         NextInst; }

      case OpUniqueStamp: { int hid,pid,tim;
         AllRecN_(new_recN, 3);
         getstamp(&hid,&pid,&tim);
         rec_(new_recN)[0] = famint_(hid); rec_(new_recN)[1] = famint_(pid);
         rec_(new_recN)[2] = famint_(tim);
         *(--AP) = (LWord)new_recN; NextInst; }

      case OpStampOfFile: { int hid,pid,tim;
         hoststring((String *)(*AP), cworkstring);
         AllRecN_(new_recN, 3);
         if (getfilestamp(&hid,&pid,&tim,cworkstring) < 0)
            {RaiseExc_(Exc_TimeStampOf);}
         rec_(new_recN)[0] = famint_(hid); rec_(new_recN)[1] = famint_(pid);
         rec_(new_recN)[2] = famint_(tim);
         *AP = (LWord)new_recN; NextInst; }

      case OpSystem:
         hoststring((String *)(*AP), cworkstring);
         /* Disable timeouts as system gets confused otherwise ... */
/*
 * Virtual alarm is BSD facility, replace `#ifdef unix' with `#ifdef BSD'...
 *
 * Sam Nelson, Stirling Univ., 20.1.88.
 */
#ifdef BSD
         signal(SIGVTALRM,SIG_IGN);
         signal(SIGPROF,SIG_IGN);
#endif
         *AP = famint_(system(cworkstring));
#ifdef BSD
#ifdef NATIVE
         if(dynamicprof) signal(SIGPROF,DynSnapShot);
#endif
#endif
#ifdef RISC_OS
         IntFlag = -7;
#else
         IntFlag = -1;

#endif
         TimeOut = 1; NextInst;

      case OpChangeDir: printf("OpChangeDir\n"); prompt(); NextInst;

      case OpBAFetch: {
        locreg_ LWord ba, offset, bsul;
        bsul = cint_(*AP++);
        offset = cint_(*AP++);
        ba = *AP;

        switch (bsul){
        case 1: *AP = famint_(*(Byte *)(stringchar_(ba)+offset)); break;
        case 2: *AP =
                famint_(((SWord *)(&(((String *)(ba))->firstchar)))[offset]);
                break;
        case 3: *AP =
                famint_(((Word *)(&(((String *)(ba))->firstchar)))[offset]);
                break;
        case 4: *AP =
                famint_(((LWord *)(&(((String *)(ba))->firstchar)))[offset]);
                break;
              };
        NextInst;}

      case OpBAStore: {
        locreg_ LWord ba, val, offset, bsul;
        bsul = cint_(*AP++);
        val = *AP++;
        offset = cint_(*AP++);
        ba = *AP;

        switch (bsul){
        case 1: stringchar_(ba)[offset] = cbyte_(val); break;
        case 2: ((SWord *)(&(((String *)(ba))->firstchar)))[offset]=cint_(val);
                break;
        case 3: ((Word *)(&(((String *)(ba))->firstchar)))[offset]=cint_(val);
                break;
        case 4: ((LWord *)(&(((String *)(ba))->firstchar)))[offset]=cint_(val);
                break;
              };
        *AP = NIL; NextInst;}


#ifdef SRGP_GRAPHICS
/*******************
 * SRGP primitives *
 * These must be kept in step with srgp.sml (library file for sml)
 *
 *
 * datatype srgp =
 *     SRGP_beep
 *   | SRGP_begin of {width:int, height:int}
 *   | SRGP_enableSynchronous
 *   | SRGP_end
 *   | SRGP_fillRectangleCoord of rectangle
 *   | SRGP_getLocator
 *   | SRGP_lineCoord of line
 *   | SRGP_pointCoord of point
 *   | SRGP_rectangleCoord of rectangle
 *   | SRGP_refresh
 *   | SRGP_setColor of color
 *   | SRGP_setInputMode of inputDevice * inputMode
 *   | SRGP_setLocatorButtonMask of button list
 *   | SRGP_setLocatorMeasure of point
 *   | SRGP_setWriteMode of srgp_writeModeType
 *   | SRGP_waitEvent of int
 *
 * and inputDevice =
 *   NO_DEVICE | LOCATOR (*| KEYBOARD*)
 *
 * and inputMode =
 *   INACTIVE | EVENT | (* SAMPLE *)
 *
 * and button =
 *   LEFT_BUTTON | MIDDLE_BUTTON | RIGHT_BUTTON
 *
 * and buttonStatus =
 *   UP | DOWN
 *
 * and color =
 *   White | Black
 *
 * and srgp_writeModeType =
 *   WRITE_REPLACE | WRITE_XOR | WRITE_OR | WRITE_AND
 *
 * withtype
 *     point = {x:int, y:int}
 * and line  = {x1:int, y1:int, x2:int, y2:int}
 * and rectangle = {bottom:int, left:int, right:int, top:int}
 *
 * datatype result =
 *   INPUTDEVICE of inputDevice | MEASURE of locatorMeasure
 *
 * withtype locatorMeasure =
 *   {position: point,
 *    last_transition: button,
 *    status: buttonStatus}
 *
 * datatype 'a option = NONE | SOME of 'a
 *
 * nonfix srgp_call 236 1;
 *
 * fun srgp_call(x:srgp):result option = srgp_call(x);
 *  *****************
 */

       case OpSrgpCall: {
         enum srgpCallType {
           SrgpCall_beep,
           SrgpCall_begin,
           SrgpCall_enableSynchronous,
           SrgpCall_end,
           SrgpCall_fillRectangleCoord,
           SrgpCall_getLocator,
           SrgpCall_lineCoord,
           SrgpCall_pointCoord,
           SrgpCall_rectangleCoord,
           SrgpCall_refresh,
           SrgpCall_setColor,
           SrgpCall_setInputMode,
           SrgpCall_setLocatorButtonMask,
           SrgpCall_setLocatorMeasure,
           SrgpCall_setWriteMode,
           SrgpCall_waitEvent};
         enum ml_writeModeType {
           ML_WRITE_AND, ML_WRITE_OR, ML_WRITE_REPLACE, ML_WRITE_XOR};
         enum ml_inputDevice {
           /*ML_KEYBOARD,*/ ML_LOCATOR, ML_NO_DEVICE};
         enum ml_inputMode {
           ML_EVENT, ML_INACTIVE /*, ML_SAMPLE*/};
         enum ml_button {
           ML_LEFT_BUTTON, ML_MIDDLE_BUTTON, ML_RIGHT_BUTTON};
         enum ml_buttonStatus {
           ML_DOWN, ML_UP};
         enum ml_color {
           ML_WHITE, ML_BLACK};
         enum ml_result {
           ML_INPUTDEVICE, ML_MEASURE};
         enum ml_option {
           ML_NONE, ML_SOME};

         locreg_ int var,x1,y1,x2,y2;
#define NONE_ famint_(ML_NONE)
         if (Ptr_(*AP)) var=varianttype_(*AP);
         else           var=cint_(*AP);
         switch (var){
         case SrgpCall_beep:
           SRGP_beep();
           *AP = NONE_ ;
           break;
         case SrgpCall_begin:
           y1 /*height*/ = cint_(fst_(((Variant *)*AP)->field));
           x1 /*width*/  = cint_(snd_(((Variant *)*AP)->field));
           SRGP_begin ("ML graphics",x1,y1,1 /*planes*/, 0 /*trace*/);
           *AP = NONE_ ;
           break;
         case SrgpCall_enableSynchronous:
           SRGP_enableSynchronous();
           *AP = NONE_ ;
           break;
         case SrgpCall_end:
           SRGP_end();
           *AP = NONE_ ;
           break;
         case SrgpCall_fillRectangleCoord:
           x1 /*left*/   = cint_(snd_(((Variant *)*AP)->field));
           y1 /*bottom*/ = cint_(fst_(((Variant *)*AP)->field));
           x2 /*right*/  = cint_(rec_(((Variant *)*AP)->field)[2]);
           y2 /*top*/    = cint_(rec_(((Variant *)*AP)->field)[3]);
           SRGP_fillRectangleCoord(x1,y1,x2,y2);
           *AP = NONE_ ;
           break;
         case SrgpCall_getLocator:
           {
             locator_measure lm;

             SRGP_getLocator(&lm);
             AllPair_(new_pair,famint_(lm.position.x),famint_(lm.position.y));
             *AP= (LWord) new_pair;
             AllRecN_(new_recN,3);
             rec_(new_recN)[1] = *AP;
             switch (lm.button_of_last_transition) {
               case LEFT_BUTTON : x1=ML_LEFT_BUTTON; break;
               case MIDDLE_BUTTON : x1=ML_MIDDLE_BUTTON; break;
               case RIGHT_BUTTON : x1=ML_RIGHT_BUTTON; break;
               default: fprintf(stderr,"Bad return val to button_olt\n");
                        x1=ML_LEFT_BUTTON;
             }
             rec_(new_recN)[0] = famint_(x1);
             switch (lm.button_chord[lm.button_of_last_transition]) {
             case UP: x1=ML_UP; break;
             case DOWN: x1=ML_DOWN; break;
             default: fprintf(stderr,"Bad return val to chord.button_olt\n");
                        x1=ML_UP;
             }
             rec_(new_recN)[2] = famint_(x1);
#define Var_(ARG) if (*AP == TRIV) *AP = famint_(ARG);      \
                 else {AllVar_(new_var, *AP, ARG); *AP = (LWord)new_var;}
/* no we have the record, package it into a result option */
             *AP=(LWord)new_recN;
             Var_(ML_MEASURE);
             Var_(ML_SOME);
#undef Var_
             break;
           }

         case SrgpCall_lineCoord:
           x1   = cint_(fst_(((Variant *)*AP)->field));
           x2   = cint_(snd_(((Variant *)*AP)->field));
           y1   = cint_(rec_(((Variant *)*AP)->field)[2]);
           y2   = cint_(rec_(((Variant *)*AP)->field)[3]);
           SRGP_lineCoord(x1,y1,x2,y2);
           *AP = NONE_ ;
           break;
         case SrgpCall_pointCoord:
           x1 = cint_(fst_(((Variant *)*AP)->field));
           y1 = cint_(snd_(((Variant *)*AP)->field));
           SRGP_pointCoord(x1,y1);
           *AP = NONE_ ;
           break;
         case SrgpCall_rectangleCoord:
           x1 /*left*/   = cint_(snd_(((Variant *)*AP)->field));
           y1 /*bottom*/ = cint_(fst_(((Variant *)*AP)->field));
           x2 /*right*/  = cint_(rec_(((Variant *)*AP)->field)[2]);
           y2 /*top*/    = cint_(rec_(((Variant *)*AP)->field)[3]);
           SRGP_rectangleCoord(x1,y1,x2,y2);
           *AP = NONE_ ;
           break;
         case SrgpCall_refresh:
           SRGP_refresh();
           *AP = NONE_ ;
           break;
         case SrgpCall_setColor:
           switch (cint_((((Variant *)*AP)->field))) {
           case ML_WHITE: x1=SRGP_WHITE; break;
           case ML_BLACK: x1=SRGP_BLACK; break;
           default: fprintf(stderr,"Bad arg to setColor\n");
           }
           SRGP_setColor(x1);
          *AP = NONE_ ; break;

         case SrgpCall_setInputMode:
          if (cint_(fst_(((Variant *)*AP)->field)) == ML_LOCATOR) {
           x1=LOCATOR;
           switch (cint_(snd_(((Variant *)*AP)->field))) {
           case ML_INACTIVE: x2=INACTIVE; break;
           case ML_EVENT: x2=EVENT; break;
           default: fprintf(stderr,"Bad arg to setInputMode\n");
             x2=INACTIVE;
           }
           SRGP_setInputMode(x1,x2);
          }
          *AP = NONE_ ; break;

         case SrgpCall_setLocatorButtonMask:
           { LWord list;
             for (list = ((Variant *)*AP)->field, x1 = 0;
                  list != NIL;
                  list = (LWord)tl_(list))
               switch (cint_(hd_(list))) {
               case ML_LEFT_BUTTON: x1 |= LEFT_BUTTON_MASK; break;
               case ML_MIDDLE_BUTTON: x1 |= MIDDLE_BUTTON_MASK; break;
               case ML_RIGHT_BUTTON: x1 |= RIGHT_BUTTON_MASK; break;
               default: fprintf(stderr,"Bad arg to setLocatorButtonMask\n");
               }
             SRGP_setLocatorButtonMask(x1);
             *AP = NONE_ ; break;
           }

         case SrgpCall_setLocatorMeasure:
           { point p;
             p.x = cint_(fst_(((Variant *)*AP)->field));
             p.y = cint_(snd_(((Variant *)*AP)->field));
             SRGP_setLocatorMeasure(p);
             *AP = NONE_ ; break;
           }


         case SrgpCall_setWriteMode:
           switch (cint_(((Variant *)*AP)->field)) {
             case ML_WRITE_AND: x1=WRITE_AND; break;
             case ML_WRITE_OR:  x1=WRITE_OR;  break;
             case ML_WRITE_REPLACE: x1= WRITE_REPLACE; break;
             case ML_WRITE_XOR: x1=WRITE_XOR; break;
             default: fprintf(stderr,"Bad arg to setWriteMode\n");
                      x1=WRITE_REPLACE;};
           SRGP_setWriteMode(x1);
           *AP = NONE_ ;
           break;

#define Var_(ARG) if (*AP == TRIV) *AP = famint_(ARG);      \
                 else {AllVar_(new_var, *AP, ARG); *AP = (LWord)new_var;}
         case SrgpCall_waitEvent:
           { inputDevice idev;
             idev = SRGP_waitEvent(cint_(((Variant *)*AP)->field));
             *AP=TRIV;
             switch (idev) { /* make object of ml type inputDevice */
             case LOCATOR: Var_(ML_LOCATOR); break;
             case NO_DEVICE: Var_(ML_NO_DEVICE); break;
             }
             /* make object of ml type result option*/
             Var_(ML_INPUTDEVICE);
             Var_(ML_SOME);
             break;
#undef Var_
           }

         default: fprintf(stderr,"Bad argument to srgp_call\007\n");
           *AP = NONE_ ;
         }
         NextInst;
       }
#endif /* SRGP_GRAPHICS */

/*<ff>Exception primitives */
/*RJG 16-Mar-89*/
/*took out handle tagging*/
      case OpNewHandle: { locreg_ LWord jmptabsize;
         *(--CP) = IPtrDiff_(CurrentProcess->ArgStk, &AP[1]);
         *(--CP) = (LWord)FP;
         *(--CP) = IPtrDiff_(CurrentProcess->CtlStk, TrapTop);
         *(--CP) = IPtrDiff_(FP -> text, PC);
         jmptabsize = PCWord_; PC = &(PC[jmptabsize*2]);
         *(--CP) = *AP++;
         TrapTop = CP;  NextInst; }


      case OpUnTrap: { locreg_ LWord displ;
         TrapTop = (LWord *)IPtrOff_(CurrentProcess->CtlStk, CP[2]);
         CP += 5; displ = PCSWord_; PC += displ;
         NextInst; }

      case OpPopTrap:
         TrapTop = (LWord *)IPtrOff_(CurrentProcess->CtlStk, CP[2]);
         CP += 5; NextInst;

      case OpRaiseMatch: RaiseExc_(Exc_Match);

      case OpNewRaise: {
         locreg_ LWord ExcCount, ExcMax;
         LWord ExcNameVec, TrapList, *Tmp;
         Exception *exception;
         int smltyp;

         exception = (Exception *)(*AP);
         smltyp = ((Immed_(exception)) || (Tag_(exception) == TagBigVar));
         goto NewTrapException;

      case OpReRaise:
         exception = (Exception *)(*AP);
         smltyp = ((Immed_(exception)) || (Tag_(exception) == TagBigVar));
         goto ReRaiseException;

FAMExc:  exception = (*(CurrentState -> BuiltInExceptions))[tmpreg];
         smltyp = 0;


NewTrapException:
         TrapStart = CP;
ReRaiseException:
         for (; ((LWord)TrapTop) != ((LWord)(CurrentProcess -> CtlStk));
              TrapTop = IPtrOff_((CurrentProcess -> CtlStk), TrapTop[2]) ) {
            if ((ExcNameVec = TrapTop[0]) == 0) {
#define notfoundTopLevel_(strptr) (memcmp(stringchar_(strptr),"<Top Level>",2))
#define printCall_(strptr,cnt) {printf("returning through  ");\
                foutstring(stringchar_(strptr),stringlength_(strptr));\
                       if (cnt != 1) printf("\t(%d times)",cnt);\
                       printf("\n");}
              int notfound,  /* haven't found the top level function call */
                  count;     /* number of function calls */
              LWord *PrevName;    /* name of last found function */

              Tmp =((FP->text)->literals)->firstfield;
              notfound = notfoundTopLevel_(Tmp);
              if (notfound) {
              printf("%s\n","Exception traceback");
              PrevName = Tmp; count = 1;
              for(; (notfound) && (TrapStart != TrapTop); TrapStart++)
                if (Ptr_(*TrapStart)) {
                  Tmp = (LWord *) (((Closure *) *TrapStart)->text);
                  if ((Ptr_(Tmp)) && (Tag_(Tmp) == TagText)) {
                    Tmp = (LWord *) ((((Text *)Tmp)->literals)->firstfield);
                    notfound = notfoundTopLevel_(Tmp);
                    if (notfound) {
                      if (Tmp==PrevName) count++;
                      else {
                        printCall_(PrevName,count);
                        PrevName = Tmp; count = 1;
                      }/*else*/
                    }/*if(notfound)*/
                  }
                }/*if(Ptr) - for */
              printCall_(PrevName,count);
              printf("returning to top level\n");
            }
              else /*found*/ printf("Exception raised at top level\n");
              ExcCount = 0; TrapStart = NIL; goto NewExcTrap2;
#undef notfoundTopLevel_
#undef printCall_
                     }
            ExcMax = arraylength_(ExcNameVec);
            for (ExcCount=0; ExcCount<ExcMax; ExcCount++) {
               LWord ExcName = rec_(ExcNameVec)[ExcCount];
               if (Immed_(ExcName)) {
                  if (ExcName == 0) goto NewExcTrap2;   /* wildcard */
                  /* olde-style traplists: */
                  if (smltyp == 0) { /* only search through list for oldfails*/
                  for (TrapList = rec_(ExcNameVec)[ExcCount+1];
                       TrapList != NIL; TrapList = (LWord)tl_(TrapList)) {
                     LWord trstr = hd_(TrapList);
                     if (stringlength_(trstr) ==
                         stringlength_(exception->excstring))
                        if (memcmp(stringchar_(exception->excstring),
                            stringchar_(trstr),stringlength_(trstr)) == 0)
                           goto NewExcTrap2;
                   }}
                  break;
                  }
               else if (exception == (Exception *)ExcName) {
                 printf("FAM: didn't expect newstyle exception\007\n");
         foutstring(stringchar_(exception->excstring),
                            stringlength_(exception->excstring));
         putchar('\n');
         prompt();
                 goto NewExcTrap2;}
               }
            }

         printf("Untrapped exception: ");
/*         foutstring(stringchar_(exception->excstring),
                            stringlength_(exception->excstring)); */
         putchar('\n');
         goto removeprocess;


NewExcTrap2:
         CP = TrapTop+5;
         FP = (Closure *)TrapTop[3];
         PC = (Byte *)IPtrOff_((FP -> text), TrapTop[1]);
         PC += PCSwTab_(ExcCount+1);
         AP = IPtrOff_((CurrentProcess -> ArgStk), TrapTop[4]);
         TrapTop = IPtrOff_((CurrentProcess -> CtlStk), TrapTop[2]);
         *(--AP) = (LWord)(exception);
#ifdef NATIVE
         if ((((FP -> text) -> PhiBC)) != NCTAG){ /* src switching */
           AJG_FP = FP;  /* change closure */
           NextInst;
         } else {
           AJG_FP = 0;  /* illrel closure */
           NEXTINNC
           }
#else
#ifdef PROFILER
         AJG_FP = FP; /* changing closure */
#endif
         NextInst;
#endif
       }

      }
   }

mlexit: ;
        /*
         * Purely aesthetic, this one.  SML is chatty enough already, so
         * adding a line that neatens up saved scripts doesn't hurt...
         *
         * Sam Nelson, Stirling Univ., 20.1.88.
         */
        fprintf(stdout,"\nML exit\n");
#ifdef DEBUGinterp
        dumpcode() ;
#endif
}

static char *ExceptNames [NumExceptions] =
     {  "Hd",   /*         "hd", */
        "Tl",   /*         "tl", */
        "ProcessLimitExceeded", /*        "ProcessLimitExceeded",*/
        "Terminated", /*        "terminated",*/
        "ProcessActive", /*        "process active",*/
        "NotOwner", /*        "not owner",*/
        "Deadlock", /*        "deadlock",*/
        "Array", /*        "Array",*/
        "Subscript", /*        "Subscript",*/
        "Update", /*        "Update",*/
        "UnimplementedBignumOp", /*        "unimplemented bignum op",*/
        "StringOfInt", /*        "stringofint",*/
        "NoFastEntryPoint", /*        "NoFastEntryPoint",*/
        "NotImplemented", /*        "Not implemented",*/
        "RealOfString", /*        "RealOfString",*/
        "Div", /*        "div",*/
        "Mod", /*        "mod",*/
        "Bind", /*        "varstruct",*/
        "Nth", /*        "nth",*/
        "ChangeDir", /*        "ChangeDir",*/
        "OpenStream", /*        "OpenStream",*/
        "CreateStream", /*        "CreateStream",*/
        "ReadStream", /*        "ReadStream",*/
        "EndOfInput", /*        "endofinput",*/
        "StreamLinkLost", /*        "Stream link lost",*/
        "ReadToTok", /*        "ReadToTok",*/
        "WriteStream", /*        "WriteStream",*/
        "MakeText", /*        "MakeText",*/
        "ImplodeAscii", /*        "implodeascii",*/
        "Substring", /*        "Substring",*/
        "StringHash", /*        "StringHash",*/
        "MoveSubstring", /*        "MoveSubstring",*/
        "StringOfLength", /*        "StringOfLength",*/
        "ScanString", /*        "ScanString",*/
        "IntOfString", /*        "intofstring",*/
        "As", /*        "as",*/
        "Outl", /*        "outl",*/
        "Outr", /*        "outr",*/
        "Corruption", /*        "corruption",*/
        "Interrupt", /*        "Interrupt",*/
        "Float", /*        "float",*/
        "CtrlZ", /*        "CtrlZ",*/
        "Reenter", /*        "Reenter",*/
        "OpcodeNoLongerSupported", /*        "Opcode no longer supported",*/
        "BigDec", /*        "BigDec",*/
        "Collect", /*        "Collect",*/
        "ExportObjFileWriteFailed", /*        "ExportObj: file write failed",*/
        "ArgStackOverFlow", /*        "ArgStackOverFlow",*/
        "CtlStackOverFlow", /*        "CtlStackOverFlow",*/
        "Floor", /*        "floor",*/
        "Sqrt", /*        "sqrt",*/
        "Exp", /*        "exp",*/
        "Ln", /*        "ln",*/
        "Quot", /*        "/",*/
        "Prod", /*      "*",*/
        "Sum", /*       "+",*/
        "Diff", /*      "-",*/
        "ImportObj", /*        "ImportObj",*/
        "TimeStampOf", /*        "TimeStampOf",*/
        "Match",
        "Abs",
        "Neg",
        "Execute" /*        "Execute"*/
};

/* Need to rewrite in terms of exc data types */

SetupExceptions()
{
   /* Temp defs */
#   undef SaveRegs_
#   undef RestoreRegs_
#   define SaveRegs_     0
#   define RestoreRegs_  0
#   define Collect(x)    \
           FatalError("No room in heap to construct new exception vector")

   Array   *NewExcVector;
   String  *NewString;
   int      OldVecSize, MinOldNew, i;  register LWord tmpreg;

   if ((OldVecSize = arraylength_(CurrentState -> BuiltInExceptions))
       != NumExceptions) {
#ifdef acorn32016
      /* hack round compiler bug */
      fprintf(stderr, "Cannot setup exceptions\n"); exit(1);
#else
/* RJG changed to reinstall ALL exceptions */
      AllArray_(new_array, NumExceptions);
      NewExcVector = new_array;

      for (i=0; i<NumExceptions; i++) {
         AllString_(new_string, strlen(ExceptNames[i]));
         NewString = new_string;
         famstring(NewString, ExceptNames[i]);
         AllPair_(new_pair, NewString, famint_(i));  /* GC could kill, if possible */
         array_(CurrentState -> BuiltInExceptions)[i] = (LWord)new_bigvar;
       }
#endif
     }
}

