stand/ficl/testmain.c

   1 /*
   2 ** stub main for testing FICL under userland
   3 ** $Id: testmain.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
   4 */
   5 /*
   6 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
   7 ** All rights reserved.
   8 **
   9 ** Get the latest Ficl release at http://ficl.sourceforge.net
  10 **
  11 ** I am interested in hearing from anyone who uses ficl. If you have
  12 ** a problem, a success story, a defect, an enhancement request, or
  13 ** if you would like to contribute to the ficl release, please
  14 ** contact me by email at the address above.
  15 **
  16 ** L I C E N S E  and  D I S C L A I M E R
  17 **
  18 ** Redistribution and use in source and binary forms, with or without
  19 ** modification, are permitted provided that the following conditions
  20 ** are met:
  21 ** 1. Redistributions of source code must retain the above copyright
  22 **    notice, this list of conditions and the following disclaimer.
  23 ** 2. Redistributions in binary form must reproduce the above copyright
  24 **    notice, this list of conditions and the following disclaimer in the
  25 **    documentation and/or other materials provided with the distribution.
  26 **
  27 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  28 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  29 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  30 ** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  31 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  32 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  33 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  34 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  35 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  36 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  37 ** SUCH DAMAGE.
  38 */
  39
  40
  41 #include <stdlib.h>
  42 #include <stdio.h>
  43 #include <string.h>
  44 #include <time.h>
  45 #include <sys/types.h>
  46 #include <sys/stat.h>
  47 #include <unistd.h>
  48
  49 #include "ficl.h"
  50
  51 /*
  52 ** Ficl interface to getcwd
  53 ** Prints the current working directory using the VM's
  54 ** textOut method...
  55 */
  56 static void ficlGetCWD(FICL_VM *pVM)
  57 {
  58     char *cp;
  59
  60     cp = getcwd(NULL, 80);
  61     vmTextOut(pVM, cp, 1);
  62     free(cp);
  63     return;
  64 }
  65
  66 /*
  67 ** Ficl interface to chdir
  68 ** Gets a newline (or NULL) delimited string from the input
  69 ** and feeds it to chdir()
  70 ** Example:
  71 **    cd c:\tmp
  72 */
  73 static void ficlChDir(FICL_VM *pVM)
  74 {
  75     FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
  76     vmGetString(pVM, pFS, '\n');
  77     if (pFS->count > 0)
  78     {
  79        int err = chdir(pFS->text);
  80        if (err)
  81         {
  82             vmTextOut(pVM, "Error: path not found", 1);
  83             vmThrow(pVM, VM_QUIT);
  84         }
  85     }
  86     else
  87     {
  88         vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
  89     }
  90     return;
  91 }
  92
  93 /*
  94 ** Ficl interface to system (ANSI)
  95 ** Gets a newline (or NULL) delimited string from the input
  96 ** and feeds it to system()
  97 ** Example:
  98 **    system rm -rf /
  99 **    \ ouch!
 100 */
 101 static void ficlSystem(FICL_VM *pVM)
 102 {
 103     FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
 104
 105     vmGetString(pVM, pFS, '\n');
 106     if (pFS->count > 0)
 107     {
 108         int err = system(pFS->text);
 109         if (err)
 110         {
 111             sprintf(pVM->pad, "System call returned %d", err);
 112             vmTextOut(pVM, pVM->pad, 1);
 113             vmThrow(pVM, VM_QUIT);
 114         }
 115     }
 116     else
 117     {
 118         vmTextOut(pVM, "Warning (system): nothing happened", 1);
 119     }
 120     return;
 121 }
 122
 123 /*
 124 ** Ficl add-in to load a text file and execute it...
 125 ** Cheesy, but illustrative.
 126 ** Line oriented... filename is newline (or NULL) delimited.
 127 ** Example:
 128 **    load test.ficl
 129 */
 130 #define nLINEBUF 256
 131 static void ficlLoad(FICL_VM *pVM)
 132 {
 133     char    cp[nLINEBUF];
 134     char    filename[nLINEBUF];
 135     FICL_STRING *pFilename = (FICL_STRING *)filename;
 136     int     nLine = 0;
 137     FILE   *fp;
 138     int     result;
 139     CELL    id;
 140     struct stat buf;
 141
 142
 143     vmGetString(pVM, pFilename, '\n');
 144
 145     if (pFilename->count <= 0)
 146     {
 147         vmTextOut(pVM, "Warning (load): nothing happened", 1);
 148         return;
 149     }
 150
 151     /*
 152     ** get the file's size and make sure it exists
 153     */
 154     result = stat( pFilename->text, &buf );
 155
 156     if (result != 0)
 157     {
 158         vmTextOut(pVM, "Unable to stat file: ", 0);
 159         vmTextOut(pVM, pFilename->text, 1);
 160         vmThrow(pVM, VM_QUIT);
 161     }
 162
 163     fp = fopen(pFilename->text, "r");
 164     if (!fp)
 165     {
 166         vmTextOut(pVM, "Unable to open file ", 0);
 167         vmTextOut(pVM, pFilename->text, 1);
 168         vmThrow(pVM, VM_QUIT);
 169     }
 170
 171     id = pVM->sourceID;
 172     pVM->sourceID.p = (void *)fp;
 173
 174     /* feed each line to ficlExec */
 175     while (fgets(cp, nLINEBUF, fp))
 176     {
 177         int len = strlen(cp) - 1;
 178
 179         nLine++;
 180         if (len <= 0)
 181             continue;
 182
 183         result = ficlExecC(pVM, cp, len);
 184         if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
 185         {
 186                 pVM->sourceID = id;
 187                 fclose(fp);
 188                 vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
 189                 break;
 190         }
 191     }
 192     /*
 193     ** Pass an empty line with SOURCE-ID == -1 to flush
 194     ** any pending REFILLs (as required by FILE wordset)
 195     */
 196     pVM->sourceID.i = -1;
 197     ficlExec(pVM, "");
 198
 199     pVM->sourceID = id;
 200     fclose(fp);
 201
 202     /* handle "bye" in loaded files. --lch */
 203     if (result == VM_USEREXIT)
 204         vmThrow(pVM, VM_USEREXIT);
 205     return;
 206 }
 207
 208 /*
 209 ** Dump a tab delimited file that summarizes the contents of the
 210 ** dictionary hash table by hashcode...
 211 */
 212 static void spewHash(FICL_VM *pVM)
 213 {
 214     FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
 215     FICL_WORD *pFW;
 216     FILE *pOut;
 217     unsigned i;
 218     unsigned nHash = pHash->size;
 219
 220     if (!vmGetWordToPad(pVM))
 221         vmThrow(pVM, VM_OUTOFTEXT);
 222
 223     pOut = fopen(pVM->pad, "w");
 224     if (!pOut)
 225     {
 226         vmTextOut(pVM, "unable to open file", 1);
 227         return;
 228     }
 229
 230     for (i=0; i < nHash; i++)
 231     {
 232         int n = 0;
 233
 234         pFW = pHash->table[i];
 235         while (pFW)
 236         {
 237             n++;
 238             pFW = pFW->link;
 239         }
 240
 241         fprintf(pOut, "%d\t%d", i, n);
 242
 243         pFW = pHash->table[i];
 244         while (pFW)
 245         {
 246             fprintf(pOut, "\t%s", pFW->name);
 247             pFW = pFW->link;
 248         }
 249
 250         fprintf(pOut, "\n");
 251     }
 252
 253     fclose(pOut);
 254     return;
 255 }
 256
 257 static void ficlBreak(FICL_VM *pVM)
 258 {
 259     pVM->state = pVM->state;
 260     return;
 261 }
 262
 263 static void ficlClock(FICL_VM *pVM)
 264 {
 265     clock_t now = clock();
 266     stackPushUNS(pVM->pStack, (FICL_UNS)now);
 267     return;
 268 }
 269
 270 static void clocksPerSec(FICL_VM *pVM)
 271 {
 272     stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
 273     return;
 274 }
 275
 276
 277 static void execxt(FICL_VM *pVM)
 278 {
 279     FICL_WORD *pFW;
 280 #if FICL_ROBUST > 1
 281     vmCheckStack(pVM, 1, 0);
 282 #endif
 283
 284     pFW = stackPopPtr(pVM->pStack);
 285     ficlExecXT(pVM, pFW);
 286
 287     return;
 288 }
 289
 290
 291 void buildTestInterface(FICL_SYSTEM *pSys)
 292 {
 293     ficlBuild(pSys, "break",    ficlBreak,    FW_DEFAULT);
 294     ficlBuild(pSys, "clock",    ficlClock,    FW_DEFAULT);
 295     ficlBuild(pSys, "cd",       ficlChDir,    FW_DEFAULT);
 296     ficlBuild(pSys, "execxt",   execxt,       FW_DEFAULT);
 297     ficlBuild(pSys, "load",     ficlLoad,     FW_DEFAULT);
 298     ficlBuild(pSys, "pwd",      ficlGetCWD,   FW_DEFAULT);
 299     ficlBuild(pSys, "system",   ficlSystem,   FW_DEFAULT);
 300     ficlBuild(pSys, "spewhash", spewHash,     FW_DEFAULT);
 301     ficlBuild(pSys, "clocks/sec",
 302                                 clocksPerSec, FW_DEFAULT);
 303
 304     return;
 305 }
 306
 307
 308 int main(int argc, char **argv)
 309 {
 310     char in[256];
 311     FICL_VM *pVM;
 312         FICL_SYSTEM *pSys;
 313
 314     pSys = ficlInitSystem(10000);
 315     buildTestInterface(pSys);
 316     pVM = ficlNewVM(pSys);
 317
 318     ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
 319
 320     /*
 321     ** load file from cmd line...
 322     */
 323     if (argc  > 1)
 324     {
 325         sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
 326         ficlEvaluate(pVM, in);
 327     }
 328
 329     for (;;)
 330     {
 331         int ret;
 332         if (fgets(in, sizeof(in) - 1, stdin) == NULL)
 333             break;
 334         ret = ficlExec(pVM, in);
 335         if (ret == VM_USEREXIT)
 336         {
 337             ficlTermSystem(pSys);
 338             break;
 339         }
 340     }
 341
 342     return 0;
 343 }
 344