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/* $FreeBSD$ */ 41 42#include <stdlib.h> 43#include <stdio.h> 44#include <string.h> 45#include <time.h> 46#include <sys/types.h> 47#include <sys/stat.h> 48#include <unistd.h> 49 50#include "ficl.h" 51 52/* 53** Ficl interface to getcwd 54** Prints the current working directory using the VM's 55** textOut method... 56*/ 57static void ficlGetCWD(FICL_VM *pVM) 58{ 59 char *cp; 60 61 cp = getcwd(NULL, 80); 62 vmTextOut(pVM, cp, 1); 63 free(cp); 64 return; 65} 66 67/* 68** Ficl interface to chdir 69** Gets a newline (or NULL) delimited string from the input 70** and feeds it to chdir() 71** Example: 72** cd c:\tmp 73*/ 74static void ficlChDir(FICL_VM *pVM) 75{ 76 FICL_STRING *pFS = (FICL_STRING *)pVM->pad; 77 vmGetString(pVM, pFS, '\n'); 78 if (pFS->count > 0) 79 { 80 int err = chdir(pFS->text); 81 if (err) 82 { 83 vmTextOut(pVM, "Error: path not found", 1); 84 vmThrow(pVM, VM_QUIT); 85 } 86 } 87 else 88 { 89 vmTextOut(pVM, "Warning (chdir): nothing happened", 1); 90 } 91 return; 92} 93 94/* 95** Ficl interface to system (ANSI) 96** Gets a newline (or NULL) delimited string from the input 97** and feeds it to system() 98** Example: 99** system rm -rf / 100** \ ouch! 101*/ 102static void ficlSystem(FICL_VM *pVM) 103{ 104 FICL_STRING *pFS = (FICL_STRING *)pVM->pad; 105 106 vmGetString(pVM, pFS, '\n'); 107 if (pFS->count > 0) 108 { 109 int err = system(pFS->text); 110 if (err) 111 { 112 sprintf(pVM->pad, "System call returned %d", err); 113 vmTextOut(pVM, pVM->pad, 1); 114 vmThrow(pVM, VM_QUIT); 115 } 116 } 117 else 118 { 119 vmTextOut(pVM, "Warning (system): nothing happened", 1); 120 } 121 return; 122} 123 124/* 125** Ficl add-in to load a text file and execute it... 126** Cheesy, but illustrative. 127** Line oriented... filename is newline (or NULL) delimited. 128** Example: 129** load test.ficl 130*/ 131#define nLINEBUF 256 132static void ficlLoad(FICL_VM *pVM) 133{ 134 char cp[nLINEBUF]; 135 char filename[nLINEBUF]; 136 FICL_STRING *pFilename = (FICL_STRING *)filename; 137 int nLine = 0; 138 FILE *fp; 139 int result; 140 CELL id; 141 struct stat buf; 142 143 144 vmGetString(pVM, pFilename, '\n'); 145 146 if (pFilename->count <= 0) 147 { 148 vmTextOut(pVM, "Warning (load): nothing happened", 1); 149 return; 150 } 151 152 /* 153 ** get the file's size and make sure it exists 154 */ 155 result = stat( pFilename->text, &buf ); 156 157 if (result != 0) 158 { 159 vmTextOut(pVM, "Unable to stat file: ", 0); 160 vmTextOut(pVM, pFilename->text, 1); 161 vmThrow(pVM, VM_QUIT); 162 } 163 164 fp = fopen(pFilename->text, "r"); 165 if (!fp) 166 { 167 vmTextOut(pVM, "Unable to open file ", 0); 168 vmTextOut(pVM, pFilename->text, 1); 169 vmThrow(pVM, VM_QUIT); 170 } 171 172 id = pVM->sourceID; 173 pVM->sourceID.p = (void *)fp; 174 175 /* feed each line to ficlExec */ 176 while (fgets(cp, nLINEBUF, fp)) 177 { 178 int len = strlen(cp) - 1; 179 180 nLine++; 181 if (len <= 0) 182 continue; 183 184 result = ficlExecC(pVM, cp, len); 185 if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT ) 186 { 187 pVM->sourceID = id; 188 fclose(fp); 189 vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine); 190 break; 191 } 192 } 193 /* 194 ** Pass an empty line with SOURCE-ID == -1 to flush 195 ** any pending REFILLs (as required by FILE wordset) 196 */ 197 pVM->sourceID.i = -1; 198 ficlExec(pVM, ""); 199 200 pVM->sourceID = id; 201 fclose(fp); 202 203 /* handle "bye" in loaded files. --lch */ 204 if (result == VM_USEREXIT) 205 vmThrow(pVM, VM_USEREXIT); 206 return; 207} 208 209/* 210** Dump a tab delimited file that summarizes the contents of the 211** dictionary hash table by hashcode... 212*/ 213static void spewHash(FICL_VM *pVM) 214{ 215 FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; 216 FICL_WORD *pFW; 217 FILE *pOut; 218 unsigned i; 219 unsigned nHash = pHash->size; 220 221 if (!vmGetWordToPad(pVM)) 222 vmThrow(pVM, VM_OUTOFTEXT); 223 224 pOut = fopen(pVM->pad, "w"); 225 if (!pOut) 226 { 227 vmTextOut(pVM, "unable to open file", 1); 228 return; 229 } 230 231 for (i=0; i < nHash; i++) 232 { 233 int n = 0; 234 235 pFW = pHash->table[i]; 236 while (pFW) 237 { 238 n++; 239 pFW = pFW->link; 240 } 241 242 fprintf(pOut, "%d\t%d", i, n); 243 244 pFW = pHash->table[i]; 245 while (pFW) 246 { 247 fprintf(pOut, "\t%s", pFW->name); 248 pFW = pFW->link; 249 } 250 251 fprintf(pOut, "\n"); 252 } 253 254 fclose(pOut); 255 return; 256} 257 258static void ficlBreak(FICL_VM *pVM) 259{ 260 pVM->state = pVM->state; 261 return; 262} 263 264static void ficlClock(FICL_VM *pVM) 265{ 266 clock_t now = clock(); 267 stackPushUNS(pVM->pStack, (FICL_UNS)now); 268 return; 269} 270 271static void clocksPerSec(FICL_VM *pVM) 272{ 273 stackPushUNS(pVM->pStack, CLOCKS_PER_SEC); 274 return; 275} 276 277 278static void execxt(FICL_VM *pVM) 279{ 280 FICL_WORD *pFW; 281#if FICL_ROBUST > 1 282 vmCheckStack(pVM, 1, 0); 283#endif 284 285 pFW = stackPopPtr(pVM->pStack); 286 ficlExecXT(pVM, pFW); 287 288 return; 289} 290 291 292void buildTestInterface(FICL_SYSTEM *pSys) 293{ 294 ficlBuild(pSys, "break", ficlBreak, FW_DEFAULT); 295 ficlBuild(pSys, "clock", ficlClock, FW_DEFAULT); 296 ficlBuild(pSys, "cd", ficlChDir, FW_DEFAULT); 297 ficlBuild(pSys, "execxt", execxt, FW_DEFAULT); 298 ficlBuild(pSys, "load", ficlLoad, FW_DEFAULT); 299 ficlBuild(pSys, "pwd", ficlGetCWD, FW_DEFAULT); 300 ficlBuild(pSys, "system", ficlSystem, FW_DEFAULT); 301 ficlBuild(pSys, "spewhash", spewHash, FW_DEFAULT); 302 ficlBuild(pSys, "clocks/sec", 303 clocksPerSec, FW_DEFAULT); 304 305 return; 306} 307 308 309int main(int argc, char **argv) 310{ 311 char in[256]; 312 FICL_VM *pVM; 313 FICL_SYSTEM *pSys; 314 315 pSys = ficlInitSystem(10000); 316 buildTestInterface(pSys); 317 pVM = ficlNewVM(pSys); 318 319 ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit"); 320 321 /* 322 ** load file from cmd line... 323 */ 324 if (argc > 1) 325 { 326 sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]); 327 ficlEvaluate(pVM, in); 328 } 329 330 for (;;) 331 { 332 int ret; 333 if (fgets(in, sizeof(in) - 1, stdin) == NULL) 334 break; 335 ret = ficlExec(pVM, in); 336 if (ret == VM_USEREXIT) 337 { 338 ficlTermSystem(pSys); 339 break; 340 } 341 } 342 343 return 0; 344} 345 346