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 345