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*/ 56static 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*/ 73static 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*/ 101static 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 131static 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*/ 212static 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 257static void ficlBreak(FICL_VM *pVM) 258{ 259 pVM->state = pVM->state; 260 return; 261} 262 263static void ficlClock(FICL_VM *pVM) 264{ 265 clock_t now = clock(); 266 stackPushUNS(pVM->pStack, (FICL_UNS)now); 267 return; 268} 269 270static void clocksPerSec(FICL_VM *pVM) 271{ 272 stackPushUNS(pVM->pStack, CLOCKS_PER_SEC); 273 return; 274} 275 276 277static 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 291void 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 308int 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 345