/*
 * File: lmisc.c
 *  Contents: create, keywd, limit, llist
 */

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



/*
 * create - return an entry block for a co-expression.
 */

OpBlock(create,1,"create",0)

Ocreate(entryp, cargp)
word *entryp;
register dptr cargp;
   {

#ifdef Coexpr
   register struct b_coexpr *sblkp;
   register struct b_refresh *rblkp;
   register dptr dp, ndp, dsp;
   register word *newsp;
   int na, nl, i;
   struct b_proc *cproc;

   /*
    * Get a new co-expression stack and initialize.
    */
   if ((sblkp = alccoexp()) == NULL) 
      RunErr(0, NULL);

   /*
    * Icon stack starts at word after co-expression stack block.  C stack
    *  starts at end of stack region on machines with down-growing C stacks
    *  and somewhere in the middle of the region.
    *
    * The C stack is aligned on a doubleword boundary.	For upgrowing
    *  stacks, the C stack starts in the middle of the stack portion
    *  of the static block.  For downgrowing stacks, the C stack starts
    *  at the end of the static block.
    */
   newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));

#ifdef UpStack
   sblkp->cstate[0] =
      ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2)
       &~(WordSize*StackAlign-1));
#else					/* UpStack */
   sblkp->cstate[0] =
	((word)((char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
#endif					/* UpStack */

#ifdef CoProcesses
   sblkp->cstate[1] = 0;
#endif


   sblkp->es_argp = (dptr )newsp;
   /*
    * Calculate number of arguments and number of local variables.
    *  na is nargs + 1 to include Arg0.
    */
   na = pfp->pf_nargs + 1;
   cproc = (struct b_proc *)BlkLoc(argp[0]);
   nl = (int)cproc->ndynam;

   /*
    * Get a refresh block for the new co-expression.
    */
   if (blkreq((word)sizeof(struct b_refresh) +
         (na + nl) * sizeof(struct descrip)) == Error) 
      RunErr(0, NULL);
   rblkp = alcrefresh(entryp, na, nl);
   sblkp->freshblk.dword = D_Refresh;
   BlkLoc(sblkp->freshblk) = (union block *) rblkp;

   /*
    * Copy current procedure frame marker into refresh block.
    */
   rblkp->pfmkr = *pfp;
   rblkp->pfmkr.pf_pfp = 0;

   /*
    * Copy arguments into refresh block and onto new stack.
    */
   dp = &argp[0];
   ndp = &rblkp->elems[0];
   dsp = (dptr)newsp;
   for (i = 1; i <= na; i++) {
      *dsp++ = *dp;
      *ndp++ = *dp++;
      }

   /*
    * Copy procedure frame to new stack and point dsp to word after frame.
    */
   *((struct pf_marker *)dsp) = *pfp;
   sblkp->es_pfp = (struct pf_marker *)dsp;
   sblkp->es_pfp->pf_pfp = 0;
   dsp = (dptr)((word *)dsp + Vwsizeof(*pfp));
   sblkp->es_ipc.opnd = entryp;
   sblkp->es_gfp = 0;
   sblkp->es_efp = 0;
   sblkp->es_ilevel = 0;
   sblkp->tvalloc = NULL;

   /*
    * Copy locals to new stack and refresh block.
    */
   dp = &(pfp->pf_locals)[0];
   for (i = 1; i <= nl; i++) {
      *dsp++ = *dp;
      *ndp++ = *dp++;
      }
   /*
    * Push two null descriptors on the stack.
    */
   *dsp++ = nulldesc;
   *dsp++ = nulldesc;

   sblkp->es_sp = (word *)dsp - 1;

   /*
    * Return the new co-expression.
    */
   Arg0.dword = D_Coexpr;
   BlkLoc(Arg0) = (union block *) sblkp;
   Return;
#else					/* Coexpr */
   RunErr(-401, NULL);
#endif					/* Coexpr */

   }

/*
 * keywd - process keyword.
 */

char *feattab[] = {
#if AMIGA
   "Amiga",
#endif					/* AMIGA */
#if ATARI_ST
   "Atari ST",
#endif					/* ATARI_ST */
#if VM
   "CMS",
#endif					/* VM */
#if HIGHC_386
   "MS-DOS/386",
#endif					/* HIGHC_386 */
#if MACINTOSH
   "Macintosh",
#endif					/* MACINTOSH */
#if MSDOS
   "MS-DOS",
#endif					/* MSDOS */
#if MVS
   "MVS",
#endif					/* MVS */
#if OS2
   "OS/2",
#endif					/* OS2 */
#if PORT
   "PORT",
#endif					/* PORT */
#if UNIX
   "UNIX",
#endif					/* VM */
#if VMS
   "VMS",
#endif					/* VMS */
#if !EBCDIC
   "ASCII",
#else					/* EBCDIC */
   "EBCDIC",
#endif					/* EBCDIC */
#ifdef IconCalling
   "calling to Icon",
#endif					/* IconCalling */
#ifdef Coexpr
   "co-expressions",
#endif					/* Coexpr */
#ifdef Header
   "direct execution",
#endif					/* Header */
#ifdef EnvVars
   "environment variables",
#endif					/* EnvVars */
#ifdef TraceBack
   "error trace back",
#endif					/* TraceBack */
#ifdef EvalTrace
   "evaluation tracing",
#endif					/* EvalTrace */
#ifdef ExecImages
   "executable images",
#endif					/* ExecImages */
#ifndef FixedRegions
   "expandable regions",
#endif					/* FixedRegions */
#ifdef ExternalFunctions
   "external functions",
#endif					/* ExternalFunctions */
#ifdef FixedRegions
   "fixed regions",
#endif					/* FixedRegions */
#ifdef KeyboardFncs
   "keyboard functions",
#endif					/* KeyboardFncs */
#ifdef LargeInts
   "large integers",
#endif					/* LargeInts */
#ifdef MathFncs
   "math functions",
#endif					/* MathFncs */
#ifdef MemMon
   "memory monitoring",
#endif					/* MEMMON */
#ifdef Pipes
   "pipes",
#endif					/* Pipes */
#ifdef RecordIO
   "record I/O",
#endif					/* RecordIO */
#ifdef StrInvoke
   "string invocation",
#endif					/* StrInvoke */
#ifdef SystemFnc
   "system function",
#endif					/* SystemFnc */
#ifdef DosFncs
   "MS-DOS extensions",
#endif					/* DosFncs */
   ""
   };

LibDcl(keywd,0,"&keywd")
   {
   register int hour;
   register word i;
   register char *merid;
   char **p;
   char sbuf[MaxCvtLen];
   extern word coll_stat, coll_str, coll_blk, coll_tot;
   long runtim;
   struct cal_time ct;

#if MACINTOSH && MPW
/* #pragma unused(nargs) */
#endif					/* MACINTOSH && MPW */

   /*
    * This is just plug and chug code.	For whatever keyword is desired,
    *  the appropriate value is dug out of the system and made into
    *  a suitable Icon value.
    *
    * A few special cases are worth noting:
    *  &pos, &random, &trace - built-in trapped variables are returned
    */
   switch ((int)IntVal(Arg0)) {
      case K_ASCII:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *) &k_ascii;
         break;
      case K_CLOCK:
         if (strreq((word)8) == Error) 
            RunErr(0, NULL);
         getitime(&ct);
         sprintf(sbuf,"%02d:%02d:%02d", ct.hour, ct.minute, ct.second);
         StrLen(Arg0) = 8;
         StrLoc(Arg0) = alcstr(sbuf,(word)8);
         break;
      case K_COLLECTIONS:
         MakeInt(coll_tot, &Arg0);
         Suspend;
         MakeInt(coll_stat, &Arg0);
         Suspend;
         MakeInt(coll_str, &Arg0);
         Suspend;
         MakeInt(coll_blk, &Arg0);
         Return;


      case K_CSET:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *) &k_cset;
         break;
      case K_CURRENT:
         Arg0 = k_current;
         break;
      case K_DATE:
         if (strreq((word)10) == Error) 
            RunErr(0, NULL);
         getitime(&ct);
         sprintf(sbuf, "%04d/%02d/%02d", ct.year, ct.month_no, ct.mday);
         StrLen(Arg0) = 10;
         StrLoc(Arg0) = alcstr(sbuf,(word)10);
         break;
      case K_DATELINE:
         getitime(&ct);
         if ((hour = ct.hour) >= 12) {
            merid = "pm";
            if (hour > 12)
               hour -= 12;
            }
         else {
            merid = "am";
            if (hour < 1)
               hour += 12;
            }
         sprintf(sbuf, "%s, %s %d, %d  %d:%02d %s", ct.wday, ct.month_nm,
            ct.mday, ct.year, hour, ct.minute, merid);
         if (strreq(i = strlen(sbuf)) == Error) 
            RunErr(0, NULL);
         StrLen(Arg0) = i;
         StrLoc(Arg0) = alcstr(sbuf, i);
         break;
      case K_DIGITS:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *)&k_digits;
         break;


      case K_ERROR:
         Arg0.dword = D_Tvkywd;
         BlkLoc(Arg0) = (union block *)&tvky_err;
         break;

      case K_ERRORNUMBER:
         if (k_errornumber == 0)
            Fail;
         MakeInt((k_errornumber > 0 ? k_errornumber : -k_errornumber), &Arg0);
         break;
      case K_ERRORTEXT:
         if (k_errornumber == 0)
            Fail;
         StrLoc(Arg0) = k_errortext;
         StrLen(Arg0) = strlen(k_errortext);
         break;
      case K_ERRORVALUE:
         if (k_errornumber <= 0)
            Fail;
         Arg0 = k_errorvalue;
         break;
      case K_ERROUT:
         Arg0.dword = D_File;
         BlkLoc(Arg0) = (union block *)&k_errout;
         break;
      case K_FEATURES:
         p = feattab;
         for(;;) {
            StrLen(Arg0) = strlen(*p);
            if (StrLen(Arg0) == 0)
               Fail;
            StrLoc(Arg0) = *p;
            Suspend;
            p++;
            }
      case K_FILE:
         StrLoc(Arg0) = findfile(ipc.opnd);
         StrLen(Arg0) = strlen(StrLoc(Arg0));
         break;


      case K_HOST:
         iconhost(sbuf);
         if (strreq(i = strlen(sbuf)) == Error) 
            RunErr(0, NULL);
         StrLen(Arg0) = i;
         StrLoc(Arg0) = alcstr(sbuf, i);
         break;
      case K_INPUT:
         Arg0.dword = D_File;
         BlkLoc(Arg0) = (union block *)&k_input;
         break;
      case K_LCASE:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *)&k_lcase;
         break;
      case K_LETTERS:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *)&k_letters;
         break;
      case K_LEVEL:
         MakeInt(k_level, &Arg0);
         break;
      case K_LINE:
         MakeInt(findline(ipc.opnd), &Arg0);
         break;
      case K_MAIN:
         Arg0 = k_main;
         break;
      case K_OUTPUT:
         Arg0.dword = D_File;
         BlkLoc(Arg0) = (union block *)&k_output;
         break;
      case K_POS:
         Arg0.dword = D_Tvkywd;
         BlkLoc(Arg0) = (union block *) &tvky_pos;
         break;
      case K_RANDOM:
         Arg0.dword = D_Tvkywd;
         BlkLoc(Arg0) = (union block *) &tvky_ran;
         break;
      case K_REGIONS:

#ifdef FixedRegions
         Arg0 = zerodesc;
#else					/* FixedRegions */
         MakeInt(DiffPtrs(statend,statbase) - mstksize, &Arg0);
#endif					/* FixedRegions */

         Suspend;
         MakeInt(DiffPtrs(strend,strbase), &Arg0);
         Suspend;
         MakeInt(DiffPtrs(blkend,blkbase), &Arg0);
         Return;

      case K_SOURCE:

#ifndef Coexpr
         Arg(0) = k_main;
#else					/* Coexpr */
 	 Arg0.dword = D_Coexpr;
 	 BlkLoc(Arg0) =
            (union block *)topact((struct b_coexpr *)BlkLoc(k_current));
#endif					/* Coexpr */

         break;
      case K_STORAGE:

#ifdef FixedRegions
         Arg0 = zerodesc;
#else					/* FixedRegions */
         MakeInt(DiffPtrs(statfree,statbase) - mstksize, &Arg0);
#endif					/* FixedRegions */

         Suspend;
         MakeInt(DiffPtrs(strfree,strbase), &Arg0);
         Suspend;
         MakeInt(DiffPtrs(blkfree,blkbase), &Arg0);
         Return;
      case K_SUBJECT:
         Arg0.dword = D_Tvkywd;
         BlkLoc(Arg0) = (union block *) &tvky_sub;
         break;
      case K_TIME:
         runtim = millisec();
         MakeInt(runtim, &Arg0);
         break;
      case K_TRACE:
         Arg0.dword = D_Tvkywd;
         BlkLoc(Arg0) = (union block *)&tvky_trc;
         break;
      case K_UCASE:
         Arg0.dword = D_Cset;
         BlkLoc(Arg0) = (union block *)&k_ucase;
         break;
      case K_VERSION:
         if (strreq(i = strlen(Version)) == Error) 
            RunErr(0, NULL);
         StrLen(Arg0) = i;
         StrLoc(Arg0) = Version;
         break;
      default:
         syserr("keyword: unknown keyword type.");
      }
   Return;
   }


/*
 * limit - explicit limitation initialization.
 */


#ifdef WATERLOO_C_V3_0
struct b_iproc Blimit = {
	T_Proc,
	Vsizeof(struct b_proc),
	Olimit,
	2,
	-1,
	0,
	0,
	{sizeof(BackSlash)-1,BackSlash}}; Olimit(nargs,cargp,sptr) register dptr cargp;
#else					/* WATERLOO_C_V3_0 */
LibDcl(limit,2,BackSlash)
#endif					/* WATERLOO_C_V3_0 */

   {

#if MACINTOSH
#if MPW
/* #pragma unused(nargs) */
#endif					/* MPW */
#endif					/* MACINTOSH */

   /*
    * The limit is both passed and returned in Arg0.  The limit must
    *  be an integer.  If the limit is 0, the expression being evaluated
    *  fails.  If the limit is < 0, it is an error.  Note that the
    *  result produced by limit is ultimately picked up by the lsusp
    *  function.
    */
   if (DeRef(Arg0) == Error) 
      RunErr(0, NULL);

   switch (cvint(&Arg0)) {

      case T_Integer:
         break;

      default:
         RunErr(101, &Arg0);
      }

   if (IntVal(Arg0) < 0) 
      RunErr(205, &Arg0);
   if (IntVal(Arg0) == 0)
      Fail;
   Return;
   }


/*
 * [ ... ] - create an explicitly specified list.
 */

LibDcl(llist,-1,"[...]")
   {
   register word i;
   register struct b_list *hp;
   register struct b_lelem *bp;
   word nslots;

   nslots = nargs;
   if (nslots == 0)
      nslots = MinListSlots;

   if (blkreq((word)sizeof(struct b_list) + sizeof(struct b_lelem) +
         nslots * sizeof(struct descrip)) == Error) 
      RunErr(0, NULL);

   /*
    * Allocate the list and a list block.
    */
   hp = alclist((word)nargs);
   bp = alclstb(nslots, (word)0, (word)nargs);

   /*
    * Make the list block just allocated into the first and last blocks
    *  for the list.
    */
   hp->listhead = hp->listtail = (union block *)bp;
   /*
    * Dereference each argument in turn and assign it to a list element.
    */
   for (i = 1; i <= nargs; i++) {
      if (DeRef(Arg(i)) == Error) 
         RunErr(0, NULL);
      bp->lslots[i-1] = Arg(i);
      }
   /*
    * Point Arg0 at the new list and return it.
    */
   ArgType(0) = D_List;
   Arg(0).vword.bptr = (union block *)hp;
   Return;
   }