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 */ 57 static 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 */ 74 static 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 */ 102 static 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 132 static 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 */ 213 static 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 258 static void ficlBreak(FICL_VM *pVM) 259 { 260 pVM->state = pVM->state; 261 return; 262 } 263 264 static void ficlClock(FICL_VM *pVM) 265 { 266 clock_t now = clock(); 267 stackPushUNS(pVM->pStack, (FICL_UNS)now); 268 return; 269 } 270 271 static void clocksPerSec(FICL_VM *pVM) 272 { 273 stackPushUNS(pVM->pStack, CLOCKS_PER_SEC); 274 return; 275 } 276 277 278 static 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 292 void 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 309 int 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