home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Lmisc < prev    next >
Encoding:
Text File  |  1990-07-19  |  13.4 KB  |  585 lines
  1. /*
  2.  * File: lmisc.c
  3.  *  Contents: create, keywd, limit, llist
  4.  */
  5.  
  6. #include "../h/config.h"
  7. #include "../h/rt.h"
  8. #include "rproto.h"
  9. #include "../h/keyword.h"
  10. #include "../h/version.h"
  11.  
  12.  
  13.  
  14. /*
  15.  * create - return an entry block for a co-expression.
  16.  */
  17.  
  18. OpBlock(create,1,"create",0)
  19.  
  20. Ocreate(entryp, cargp)
  21. word *entryp;
  22. register dptr cargp;
  23.    {
  24.  
  25. #ifdef Coexpr
  26.    register struct b_coexpr *sblkp;
  27.    register struct b_refresh *rblkp;
  28.    register dptr dp, ndp, dsp;
  29.    register word *newsp;
  30.    int na, nl, i;
  31.    struct b_proc *cproc;
  32.  
  33.    /*
  34.     * Get a new co-expression stack and initialize.
  35.     */
  36.    if ((sblkp = alccoexp()) == NULL) 
  37.       RunErr(0, NULL);
  38.  
  39.    /*
  40.     * Icon stack starts at word after co-expression stack block.  C stack
  41.     *  starts at end of stack region on machines with down-growing C stacks
  42.     *  and somewhere in the middle of the region.
  43.     *
  44.     * The C stack is aligned on a doubleword boundary.    For upgrowing
  45.     *  stacks, the C stack starts in the middle of the stack portion
  46.     *  of the static block.  For downgrowing stacks, the C stack starts
  47.     *  at the end of the static block.
  48.     */
  49.    newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));
  50.  
  51. #ifdef UpStack
  52.    sblkp->cstate[0] =
  53.       ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2)
  54.        &~(WordSize*StackAlign-1));
  55. #else                    /* UpStack */
  56.    sblkp->cstate[0] =
  57.     ((word)((char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
  58. #endif                    /* UpStack */
  59.  
  60. #ifdef CoProcesses
  61.    sblkp->cstate[1] = 0;
  62. #endif
  63.  
  64.  
  65.    sblkp->es_argp = (dptr )newsp;
  66.    /*
  67.     * Calculate number of arguments and number of local variables.
  68.     *  na is nargs + 1 to include Arg0.
  69.     */
  70.    na = pfp->pf_nargs + 1;
  71.    cproc = (struct b_proc *)BlkLoc(argp[0]);
  72.    nl = (int)cproc->ndynam;
  73.  
  74.    /*
  75.     * Get a refresh block for the new co-expression.
  76.     */
  77.    if (blkreq((word)sizeof(struct b_refresh) +
  78.          (na + nl) * sizeof(struct descrip)) == Error) 
  79.       RunErr(0, NULL);
  80.    rblkp = alcrefresh(entryp, na, nl);
  81.    sblkp->freshblk.dword = D_Refresh;
  82.    BlkLoc(sblkp->freshblk) = (union block *) rblkp;
  83.  
  84.    /*
  85.     * Copy current procedure frame marker into refresh block.
  86.     */
  87.    rblkp->pfmkr = *pfp;
  88.    rblkp->pfmkr.pf_pfp = 0;
  89.  
  90.    /*
  91.     * Copy arguments into refresh block and onto new stack.
  92.     */
  93.    dp = &argp[0];
  94.    ndp = &rblkp->elems[0];
  95.    dsp = (dptr)newsp;
  96.    for (i = 1; i <= na; i++) {
  97.       *dsp++ = *dp;
  98.       *ndp++ = *dp++;
  99.       }
  100.  
  101.    /*
  102.     * Copy procedure frame to new stack and point dsp to word after frame.
  103.     */
  104.    *((struct pf_marker *)dsp) = *pfp;
  105.    sblkp->es_pfp = (struct pf_marker *)dsp;
  106.    sblkp->es_pfp->pf_pfp = 0;
  107.    dsp = (dptr)((word *)dsp + Vwsizeof(*pfp));
  108.    sblkp->es_ipc.opnd = entryp;
  109.    sblkp->es_gfp = 0;
  110.    sblkp->es_efp = 0;
  111.    sblkp->es_ilevel = 0;
  112.    sblkp->tvalloc = NULL;
  113.  
  114.    /*
  115.     * Copy locals to new stack and refresh block.
  116.     */
  117.    dp = &(pfp->pf_locals)[0];
  118.    for (i = 1; i <= nl; i++) {
  119.       *dsp++ = *dp;
  120.       *ndp++ = *dp++;
  121.       }
  122.    /*
  123.     * Push two null descriptors on the stack.
  124.     */
  125.    *dsp++ = nulldesc;
  126.    *dsp++ = nulldesc;
  127.  
  128.    sblkp->es_sp = (word *)dsp - 1;
  129.  
  130.    /*
  131.     * Return the new co-expression.
  132.     */
  133.    Arg0.dword = D_Coexpr;
  134.    BlkLoc(Arg0) = (union block *) sblkp;
  135.    Return;
  136. #else                    /* Coexpr */
  137.    RunErr(-401, NULL);
  138. #endif                    /* Coexpr */
  139.  
  140.    }
  141.  
  142. /*
  143.  * keywd - process keyword.
  144.  */
  145.  
  146. char *feattab[] = {
  147. #if AMIGA
  148.    "Amiga",
  149. #endif                    /* AMIGA */
  150. #if ARM
  151.    "Acorn Archimedes",
  152. #endif                    /* ARM */
  153. #if ATARI_ST
  154.    "Atari ST",
  155. #endif                    /* ATARI_ST */
  156. #if VM
  157.    "CMS",
  158. #endif                    /* VM */
  159. #if HIGHC_386
  160.    "MS-DOS/386",
  161. #endif                    /* HIGHC_386 */
  162. #if MACINTOSH
  163.    "Macintosh",
  164. #endif                    /* MACINTOSH */
  165. #if MSDOS
  166.    "MS-DOS",
  167. #endif                    /* MSDOS */
  168. #if MVS
  169.    "MVS",
  170. #endif                    /* MVS */
  171. #if OS2
  172.    "OS/2",
  173. #endif                    /* OS2 */
  174. #if PORT
  175.    "PORT",
  176. #endif                    /* PORT */
  177. #if UNIX
  178.    "UNIX",
  179. #endif                    /* VM */
  180. #if VMS
  181.    "VMS",
  182. #endif                    /* VMS */
  183. #if !EBCDIC
  184.    "ASCII",
  185. #else                    /* EBCDIC */
  186.    "EBCDIC",
  187. #endif                    /* EBCDIC */
  188. #ifdef IconCalling
  189.    "calling to Icon",
  190. #endif                    /* IconCalling */
  191. #ifdef Coexpr
  192.    "co-expressions",
  193. #endif                    /* Coexpr */
  194. #ifdef Header
  195.    "direct execution",
  196. #endif                    /* Header */
  197. #ifdef EnvVars
  198.    "environment variables",
  199. #endif                    /* EnvVars */
  200. #ifdef TraceBack
  201.    "error trace back",
  202. #endif                    /* TraceBack */
  203. #ifdef EvalTrace
  204.    "evaluation tracing",
  205. #endif                    /* EvalTrace */
  206. #ifdef ExecImages
  207.    "executable images",
  208. #endif                    /* ExecImages */
  209. #ifndef FixedRegions
  210.    "expandable regions",
  211. #endif                    /* FixedRegions */
  212. #ifdef ExternalFunctions
  213.    "external functions",
  214. #endif                    /* ExternalFunctions */
  215. #ifdef FixedRegions
  216.    "fixed regions",
  217. #endif                    /* FixedRegions */
  218. #ifdef KeyboardFncs
  219.    "keyboard functions",
  220. #endif                    /* KeyboardFncs */
  221. #ifdef LargeInts
  222.    "large integers",
  223. #endif                    /* LargeInts */
  224. #ifdef MathFncs
  225.    "math functions",
  226. #endif                    /* MathFncs */
  227. #ifdef MemMon
  228.    "memory monitoring",
  229. #endif                    /* MEMMON */
  230. #ifdef Pipes
  231.    "pipes",
  232. #endif                    /* Pipes */
  233. #ifdef RecordIO
  234.    "record I/O",
  235. #endif                    /* RecordIO */
  236. #ifdef StrInvoke
  237.    "string invocation",
  238. #endif                    /* StrInvoke */
  239. #ifdef SystemFnc
  240.    "system function",
  241. #endif                    /* SystemFnc */
  242. #ifdef DosFncs
  243.    "MS-DOS extensions",
  244. #endif                    /* DosFncs */
  245. #ifdef ArmFncs
  246.    "Archimedes extensions",
  247. #endif                    /* ArmFncs */
  248.    ""
  249.    };
  250.  
  251. LibDcl(keywd,0,"&keywd")
  252.    {
  253.    register int hour;
  254.    register word i;
  255.    register char *merid;
  256.    char **p;
  257.    char sbuf[MaxCvtLen];
  258.    extern word coll_stat, coll_str, coll_blk, coll_tot;
  259.    long runtim;
  260.    struct cal_time ct;
  261.  
  262. #if MACINTOSH && MPW
  263. /* #pragma unused(nargs) */
  264. #endif                    /* MACINTOSH && MPW */
  265.  
  266.    /*
  267.     * This is just plug and chug code.    For whatever keyword is desired,
  268.     *  the appropriate value is dug out of the system and made into
  269.     *  a suitable Icon value.
  270.     *
  271.     * A few special cases are worth noting:
  272.     *  &pos, &random, &trace - built-in trapped variables are returned
  273.     */
  274.    switch ((int)IntVal(Arg0)) {
  275.       case K_ASCII:
  276.          Arg0.dword = D_Cset;
  277.          BlkLoc(Arg0) = (union block *) &k_ascii;
  278.          break;
  279.       case K_CLOCK:
  280.          if (strreq((word)8) == Error) 
  281.             RunErr(0, NULL);
  282.          getitime(&ct);
  283.          sprintf(sbuf,"%02d:%02d:%02d", ct.hour, ct.minute, ct.second);
  284.          StrLen(Arg0) = 8;
  285.          StrLoc(Arg0) = alcstr(sbuf,(word)8);
  286.          break;
  287.       case K_COLLECTIONS:
  288.          MakeInt(coll_tot, &Arg0);
  289.          Suspend;
  290.          MakeInt(coll_stat, &Arg0);
  291.          Suspend;
  292.          MakeInt(coll_str, &Arg0);
  293.          Suspend;
  294.          MakeInt(coll_blk, &Arg0);
  295.          Return;
  296.  
  297.  
  298.       case K_CSET:
  299.          Arg0.dword = D_Cset;
  300.          BlkLoc(Arg0) = (union block *) &k_cset;
  301.          break;
  302.       case K_CURRENT:
  303.          Arg0 = k_current;
  304.          break;
  305.       case K_DATE:
  306.          if (strreq((word)10) == Error) 
  307.             RunErr(0, NULL);
  308.          getitime(&ct);
  309.          sprintf(sbuf, "%04d/%02d/%02d", ct.year, ct.month_no, ct.mday);
  310.          StrLen(Arg0) = 10;
  311.          StrLoc(Arg0) = alcstr(sbuf,(word)10);
  312.          break;
  313.       case K_DATELINE:
  314.          getitime(&ct);
  315.          if ((hour = ct.hour) >= 12) {
  316.             merid = "pm";
  317.             if (hour > 12)
  318.                hour -= 12;
  319.             }
  320.          else {
  321.             merid = "am";
  322.             if (hour < 1)
  323.                hour += 12;
  324.             }
  325.          sprintf(sbuf, "%s, %s %d, %d  %d:%02d %s", ct.wday, ct.month_nm,
  326.             ct.mday, ct.year, hour, ct.minute, merid);
  327.          if (strreq(i = strlen(sbuf)) == Error) 
  328.             RunErr(0, NULL);
  329.          StrLen(Arg0) = i;
  330.          StrLoc(Arg0) = alcstr(sbuf, i);
  331.          break;
  332.       case K_DIGITS:
  333.          Arg0.dword = D_Cset;
  334.          BlkLoc(Arg0) = (union block *)&k_digits;
  335.          break;
  336.  
  337.  
  338.       case K_ERROR:
  339.          Arg0.dword = D_Tvkywd;
  340.          BlkLoc(Arg0) = (union block *)&tvky_err;
  341.          break;
  342.  
  343.       case K_ERRORNUMBER:
  344.          if (k_errornumber == 0)
  345.             Fail;
  346.          MakeInt((k_errornumber > 0 ? k_errornumber : -k_errornumber), &Arg0);
  347.          break;
  348.       case K_ERRORTEXT:
  349.          if (k_errornumber == 0)
  350.             Fail;
  351.          StrLoc(Arg0) = k_errortext;
  352.          StrLen(Arg0) = strlen(k_errortext);
  353.          break;
  354.       case K_ERRORVALUE:
  355.          if (k_errornumber <= 0)
  356.             Fail;
  357.          Arg0 = k_errorvalue;
  358.          break;
  359.       case K_ERROUT:
  360.          Arg0.dword = D_File;
  361.          BlkLoc(Arg0) = (union block *)&k_errout;
  362.          break;
  363.       case K_FEATURES:
  364.          p = feattab;
  365.          for(;;) {
  366.             StrLen(Arg0) = strlen(*p);
  367.             if (StrLen(Arg0) == 0)
  368.                Fail;
  369.             StrLoc(Arg0) = *p;
  370.             Suspend;
  371.             p++;
  372.             }
  373.       case K_FILE:
  374.          StrLoc(Arg0) = findfile(ipc.opnd);
  375.          StrLen(Arg0) = strlen(StrLoc(Arg0));
  376.          break;
  377.  
  378.  
  379.       case K_HOST:
  380.          iconhost(sbuf);
  381.          if (strreq(i = strlen(sbuf)) == Error) 
  382.             RunErr(0, NULL);
  383.          StrLen(Arg0) = i;
  384.          StrLoc(Arg0) = alcstr(sbuf, i);
  385.          break;
  386.       case K_INPUT:
  387.          Arg0.dword = D_File;
  388.          BlkLoc(Arg0) = (union block *)&k_input;
  389.          break;
  390.       case K_LCASE:
  391.          Arg0.dword = D_Cset;
  392.          BlkLoc(Arg0) = (union block *)&k_lcase;
  393.          break;
  394.       case K_LETTERS:
  395.          Arg0.dword = D_Cset;
  396.          BlkLoc(Arg0) = (union block *)&k_letters;
  397.          break;
  398.       case K_LEVEL:
  399.          MakeInt(k_level, &Arg0);
  400.          break;
  401.       case K_LINE:
  402.          MakeInt(findline(ipc.opnd), &Arg0);
  403.          break;
  404.       case K_MAIN:
  405.          Arg0 = k_main;
  406.          break;
  407.       case K_OUTPUT:
  408.          Arg0.dword = D_File;
  409.          BlkLoc(Arg0) = (union block *)&k_output;
  410.          break;
  411.       case K_POS:
  412.          Arg0.dword = D_Tvkywd;
  413.          BlkLoc(Arg0) = (union block *) &tvky_pos;
  414.          break;
  415.       case K_RANDOM:
  416.          Arg0.dword = D_Tvkywd;
  417.          BlkLoc(Arg0) = (union block *) &tvky_ran;
  418.          break;
  419.       case K_REGIONS:
  420.  
  421. #ifdef FixedRegions
  422.          Arg0 = zerodesc;
  423. #else                    /* FixedRegions */
  424.          MakeInt(DiffPtrs(statend,statbase) - mstksize, &Arg0);
  425. #endif                    /* FixedRegions */
  426.  
  427.          Suspend;
  428.          MakeInt(DiffPtrs(strend,strbase), &Arg0);
  429.          Suspend;
  430.          MakeInt(DiffPtrs(blkend,blkbase), &Arg0);
  431.          Return;
  432.  
  433.       case K_SOURCE:
  434.  
  435. #ifndef Coexpr
  436.          Arg(0) = k_main;
  437. #else                    /* Coexpr */
  438.       Arg0.dword = D_Coexpr;
  439.       BlkLoc(Arg0) =
  440.             (union block *)topact((struct b_coexpr *)BlkLoc(k_current));
  441. #endif                    /* Coexpr */
  442.  
  443.          break;
  444.       case K_STORAGE:
  445.  
  446. #ifdef FixedRegions
  447.          Arg0 = zerodesc;
  448. #else                    /* FixedRegions */
  449.          MakeInt(DiffPtrs(statfree,statbase) - mstksize, &Arg0);
  450. #endif                    /* FixedRegions */
  451.  
  452.          Suspend;
  453.          MakeInt(DiffPtrs(strfree,strbase), &Arg0);
  454.          Suspend;
  455.          MakeInt(DiffPtrs(blkfree,blkbase), &Arg0);
  456.          Return;
  457.       case K_SUBJECT:
  458.          Arg0.dword = D_Tvkywd;
  459.          BlkLoc(Arg0) = (union block *) &tvky_sub;
  460.          break;
  461.       case K_TIME:
  462.          runtim = millisec();
  463.          MakeInt(runtim, &Arg0);
  464.          break;
  465.       case K_TRACE:
  466.          Arg0.dword = D_Tvkywd;
  467.          BlkLoc(Arg0) = (union block *)&tvky_trc;
  468.          break;
  469.       case K_UCASE:
  470.          Arg0.dword = D_Cset;
  471.          BlkLoc(Arg0) = (union block *)&k_ucase;
  472.          break;
  473.       case K_VERSION:
  474.          if (strreq(i = strlen(Version)) == Error) 
  475.             RunErr(0, NULL);
  476.          StrLen(Arg0) = i;
  477.          StrLoc(Arg0) = Version;
  478.          break;
  479.       default:
  480.          syserr("keyword: unknown keyword type.");
  481.       }
  482.    Return;
  483.    }
  484.  
  485.  
  486. /*
  487.  * limit - explicit limitation initialization.
  488.  */
  489.  
  490.  
  491. #ifdef WATERLOO_C_V3_0
  492. struct b_iproc Blimit = {
  493.     T_Proc,
  494.     Vsizeof(struct b_proc),
  495.     Olimit,
  496.     2,
  497.     -1,
  498.     0,
  499.     0,
  500.     {sizeof(BackSlash)-1,BackSlash}}; Olimit(nargs,cargp,sptr) register dptr cargp;
  501. #else                    /* WATERLOO_C_V3_0 */
  502. LibDcl(limit,2,BackSlash)
  503. #endif                    /* WATERLOO_C_V3_0 */
  504.  
  505.    {
  506.  
  507. #if MACINTOSH
  508. #if MPW
  509. /* #pragma unused(nargs) */
  510. #endif                    /* MPW */
  511. #endif                    /* MACINTOSH */
  512.  
  513.    /*
  514.     * The limit is both passed and returned in Arg0.  The limit must
  515.     *  be an integer.  If the limit is 0, the expression being evaluated
  516.     *  fails.  If the limit is < 0, it is an error.  Note that the
  517.     *  result produced by limit is ultimately picked up by the lsusp
  518.     *  function.
  519.     */
  520.    if (DeRef(Arg0) == Error) 
  521.       RunErr(0, NULL);
  522.  
  523.    switch (cvint(&Arg0)) {
  524.  
  525.       case T_Integer:
  526.          break;
  527.  
  528.       default:
  529.          RunErr(101, &Arg0);
  530.       }
  531.  
  532.    if (IntVal(Arg0) < 0) 
  533.       RunErr(205, &Arg0);
  534.    if (IntVal(Arg0) == 0)
  535.       Fail;
  536.    Return;
  537.    }
  538.  
  539.  
  540. /*
  541.  * [ ... ] - create an explicitly specified list.
  542.  */
  543.  
  544. LibDcl(llist,-1,"[...]")
  545.    {
  546.    register word i;
  547.    register struct b_list *hp;
  548.    register struct b_lelem *bp;
  549.    word nslots;
  550.  
  551.    nslots = nargs;
  552.    if (nslots == 0)
  553.       nslots = MinListSlots;
  554.  
  555.    if (blkreq((word)sizeof(struct b_list) + sizeof(struct b_lelem) +
  556.          nslots * sizeof(struct descrip)) == Error) 
  557.       RunErr(0, NULL);
  558.  
  559.    /*
  560.     * Allocate the list and a list block.
  561.     */
  562.    hp = alclist((word)nargs);
  563.    bp = alclstb(nslots, (word)0, (word)nargs);
  564.  
  565.    /*
  566.     * Make the list block just allocated into the first and last blocks
  567.     *  for the list.
  568.     */
  569.    hp->listhead = hp->listtail = (union block *)bp;
  570.    /*
  571.     * Dereference each argument in turn and assign it to a list element.
  572.     */
  573.    for (i = 1; i <= nargs; i++) {
  574.       if (DeRef(Arg(i)) == Error) 
  575.          RunErr(0, NULL);
  576.       bp->lslots[i-1] = Arg(i);
  577.       }
  578.    /*
  579.     * Point Arg0 at the new list and return it.
  580.     */
  581.    ArgType(0) = D_List;
  582.    Arg(0).vword.bptr = (union block *)hp;
  583.    Return;
  584.    }
  585.