1 /*
2 * f i c l . c
3 * Forth Inspired Command Language - external interface
4 * Author: John Sadler (john_sadler@alum.mit.edu)
5 * Created: 19 July 1997
6 * $Id: system.c,v 1.2 2010/09/10 10:35:54 asau Exp $
7 */
8 /*
9 * This is an ANS Forth interpreter written in C.
10 * Ficl uses Forth syntax for its commands, but turns the Forth
11 * model on its head in other respects.
12 * Ficl provides facilities for interoperating
13 * with programs written in C: C functions can be exported to Ficl,
14 * and Ficl commands can be executed via a C calling interface. The
15 * interpreter is re-entrant, so it can be used in multiple instances
16 * in a multitasking system. Unlike Forth, Ficl's outer interpreter
17 * expects a text block as input, and returns to the caller after each
18 * text block, so the data pump is somewhere in external code in the
19 * style of TCL.
20 *
21 * Code is written in ANSI C for portability.
22 */
23 /*
24 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
25 * All rights reserved.
26 *
27 * Get the latest Ficl release at http://ficl.sourceforge.net
28 *
29 * I am interested in hearing from anyone who uses Ficl. If you have
30 * a problem, a success story, a defect, an enhancement request, or
31 * if you would like to contribute to the Ficl release, please
32 * contact me by email at the address above.
33 *
34 * L I C E N S E and D I S C L A I M E R
35 *
36 * Redistribution and use in source and binary forms, with or without
37 * modification, are permitted provided that the following conditions
38 * are met:
39 * 1. Redistributions of source code must retain the above copyright
40 * notice, this list of conditions and the following disclaimer.
41 * 2. Redistributions in binary form must reproduce the above copyright
42 * notice, this list of conditions and the following disclaimer in the
43 * documentation and/or other materials provided with the distribution.
44 *
45 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
46 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
47 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
48 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
49 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
50 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
51 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
52 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
53 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
54 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
55 * SUCH DAMAGE.
56 */
57
58 #include "ficl.h"
59
60 /*
61 * System statics
62 * Each ficlSystem builds a global dictionary during its start
63 * sequence. This is shared by all virtual machines of that system.
64 * Therefore only one VM can update the dictionary
65 * at a time. The system imports a locking function that
66 * you can override in order to control update access to
67 * the dictionary. The function is stubbed out by default,
68 * but you can insert one: #define FICL_WANT_MULTITHREADED 1
69 * and supply your own version of ficlDictionaryLock.
70 */
71
72 ficlSystem *ficlSystemGlobal = NULL;
73
74 /*
75 * f i c l S e t V e r s i o n E n v
76 * Create a double ficlCell environment constant for the version ID
77 */
78 static void
ficlSystemSetVersion(ficlSystem * system)79 ficlSystemSetVersion(ficlSystem *system)
80 {
81 int major = FICL_VERSION_MAJOR;
82 int minor = FICL_VERSION_MINOR;
83 ficl2Integer combined;
84 ficlDictionary *environment = ficlSystemGetEnvironment(system);
85 FICL_2INTEGER_SET(major, minor, combined);
86 ficlDictionarySet2Constant(environment, "ficl-version", combined);
87 ficlDictionarySetConstant(environment, "ficl-robust", FICL_ROBUST);
88 }
89
90 /*
91 * f i c l I n i t S y s t e m
92 * Binds a global dictionary to the interpreter system.
93 * You specify the address and size of the allocated area.
94 * After that, Ficl manages it.
95 * First step is to set up the static pointers to the area.
96 * Then write the "precompiled" portion of the dictionary in.
97 * The dictionary needs to be at least large enough to hold the
98 * precompiled part. Try 1K cells minimum. Use "words" to find
99 * out how much of the dictionary is used at any time.
100 */
101 ficlSystem *
ficlSystemCreate(ficlSystemInformation * fsi)102 ficlSystemCreate(ficlSystemInformation *fsi)
103 {
104 ficlInteger dictionarySize;
105 ficlInteger environmentSize;
106 ficlInteger stackSize;
107 ficlSystem *system;
108 ficlCallback callback;
109 ficlSystemInformation fauxInfo;
110 ficlDictionary *environment;
111
112 if (fsi == NULL) {
113 fsi = &fauxInfo;
114 ficlSystemInformationInitialize(fsi);
115 }
116
117 callback.context = fsi->context;
118 callback.textOut = fsi->textOut;
119 callback.errorOut = fsi->errorOut;
120 callback.system = NULL;
121 callback.vm = NULL;
122
123 FICL_ASSERT(&callback, sizeof (ficlInteger) >= sizeof (void *));
124 FICL_ASSERT(&callback, sizeof (ficlUnsigned) >= sizeof (void *));
125 #if (FICL_WANT_FLOAT)
126 FICL_ASSERT(&callback, sizeof (ficlFloat) <= sizeof (ficlInteger));
127 #endif
128
129 system = ficlMalloc(sizeof (ficlSystem));
130
131 FICL_ASSERT(&callback, system);
132
133 memset(system, 0, sizeof (ficlSystem));
134
135 dictionarySize = fsi->dictionarySize;
136 if (dictionarySize <= 0)
137 dictionarySize = FICL_DEFAULT_DICTIONARY_SIZE;
138
139 environmentSize = fsi->environmentSize;
140 if (environmentSize <= 0)
141 environmentSize = FICL_DEFAULT_ENVIRONMENT_SIZE;
142
143 stackSize = fsi->stackSize;
144 if (stackSize < FICL_DEFAULT_STACK_SIZE)
145 stackSize = FICL_DEFAULT_STACK_SIZE;
146
147 system->dictionary = ficlDictionaryCreateHashed(system,
148 (unsigned)dictionarySize, FICL_HASH_SIZE);
149 system->dictionary->forthWordlist->name = "forth-wordlist";
150
151 environment = ficlDictionaryCreate(system, (unsigned)environmentSize);
152 system->environment = environment;
153 system->environment->forthWordlist->name = "environment";
154
155 system->callback.textOut = fsi->textOut;
156 system->callback.errorOut = fsi->errorOut;
157 system->callback.context = fsi->context;
158 system->callback.system = system;
159 system->callback.vm = NULL;
160 system->stackSize = stackSize;
161
162 #if FICL_WANT_LOCALS
163 /*
164 * The locals dictionary is only searched while compiling,
165 * but this is where speed is most important. On the other
166 * hand, the dictionary gets emptied after each use of locals
167 * The need to balance search speed with the cost of the 'empty'
168 * operation led me to select a single-threaded list...
169 */
170 system->locals = ficlDictionaryCreate(system,
171 (unsigned)FICL_MAX_LOCALS * FICL_CELLS_PER_WORD);
172 #endif /* FICL_WANT_LOCALS */
173
174 /*
175 * Build the precompiled dictionary and load softwords. We need
176 * a temporary VM to do this - ficlNewVM links one to the head of
177 * the system VM list. ficlCompilePlatform (defined in win32.c,
178 * for example) adds platform specific words.
179 */
180 ficlSystemCompileCore(system);
181 ficlSystemCompilePrefix(system);
182
183 #if FICL_WANT_FLOAT
184 ficlSystemCompileFloat(system);
185 #endif /* FICL_WANT_FLOAT */
186
187 #if FICL_WANT_PLATFORM
188 ficlSystemCompilePlatform(system);
189 #endif /* FICL_WANT_PLATFORM */
190
191 ficlSystemSetVersion(system);
192
193 /*
194 * Establish the parse order. Note that prefixes precede numbers -
195 * this allows constructs like "0b101010" which might parse as a
196 * hex value otherwise.
197 */
198 ficlSystemAddPrimitiveParseStep(system, "?word", ficlVmParseWord);
199 ficlSystemAddPrimitiveParseStep(system, "?prefix", ficlVmParsePrefix);
200 ficlSystemAddPrimitiveParseStep(system, "?number", ficlVmParseNumber);
201 #if FICL_WANT_FLOAT
202 ficlSystemAddPrimitiveParseStep(system, "?float",
203 ficlVmParseFloatNumber);
204 #endif
205
206 /*
207 * Now create a temporary VM to compile the softwords. Since all VMs
208 * are linked into the vmList of ficlSystem, we don't have to pass
209 * the VM to ficlCompileSoftCore -- it just hijacks whatever it finds
210 * in the VM list. Ficl 2.05: vmCreate no longer depends on the
211 * presence of INTERPRET in the dictionary, so a VM can be created
212 * before the dictionary is built. It just can't do much...
213 */
214 ficlSystemCreateVm(system);
215 #define ADD_COMPILE_FLAG(name) \
216 ficlDictionarySetConstant(environment, #name, name)
217 ADD_COMPILE_FLAG(FICL_WANT_LZ4_SOFTCORE);
218 ADD_COMPILE_FLAG(FICL_WANT_FILE);
219 ADD_COMPILE_FLAG(FICL_WANT_FLOAT);
220 ADD_COMPILE_FLAG(FICL_WANT_DEBUGGER);
221 ADD_COMPILE_FLAG(FICL_WANT_EXTENDED_PREFIX);
222 ADD_COMPILE_FLAG(FICL_WANT_USER);
223 ADD_COMPILE_FLAG(FICL_WANT_LOCALS);
224 ADD_COMPILE_FLAG(FICL_WANT_OOP);
225 ADD_COMPILE_FLAG(FICL_WANT_SOFTWORDS);
226 ADD_COMPILE_FLAG(FICL_WANT_MULTITHREADED);
227 ADD_COMPILE_FLAG(FICL_WANT_OPTIMIZE);
228 ADD_COMPILE_FLAG(FICL_WANT_VCALL);
229
230 ADD_COMPILE_FLAG(FICL_PLATFORM_ALIGNMENT);
231
232 ADD_COMPILE_FLAG(FICL_ROBUST);
233
234 #define ADD_COMPILE_STRING(name) \
235 ficlDictionarySetConstantString(environment, #name, name)
236 ADD_COMPILE_STRING(FICL_PLATFORM_ARCHITECTURE);
237 ADD_COMPILE_STRING(FICL_PLATFORM_OS);
238
239 ficlSystemCompileSoftCore(system);
240 ficlSystemDestroyVm(system->vmList);
241
242 if (ficlSystemGlobal == NULL)
243 ficlSystemGlobal = system;
244
245 return (system);
246 }
247
248 /*
249 * f i c l T e r m S y s t e m
250 * Tear the system down by deleting the dictionaries and all VMs.
251 * This saves you from having to keep track of all that stuff.
252 */
253 void
ficlSystemDestroy(ficlSystem * system)254 ficlSystemDestroy(ficlSystem *system)
255 {
256 if (system->dictionary)
257 ficlDictionaryDestroy(system->dictionary);
258 system->dictionary = NULL;
259
260 if (system->environment)
261 ficlDictionaryDestroy(system->environment);
262 system->environment = NULL;
263
264 #if FICL_WANT_LOCALS
265 if (system->locals)
266 ficlDictionaryDestroy(system->locals);
267 system->locals = NULL;
268 #endif
269
270 while (system->vmList != NULL) {
271 ficlVm *vm = system->vmList;
272 system->vmList = system->vmList->link;
273 ficlVmDestroy(vm);
274 }
275
276 if (ficlSystemGlobal == system)
277 ficlSystemGlobal = NULL;
278
279 ficlFree(system);
280 system = NULL;
281 }
282
283 /*
284 * f i c l A d d P a r s e S t e p
285 * Appends a parse step function to the end of the parse list (see
286 * ficlParseStep notes in ficl.h for details). Returns 0 if successful,
287 * nonzero if there's no more room in the list.
288 */
289 int
ficlSystemAddParseStep(ficlSystem * system,ficlWord * word)290 ficlSystemAddParseStep(ficlSystem *system, ficlWord *word)
291 {
292 int i;
293 for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
294 if (system->parseList[i] == NULL) {
295 system->parseList[i] = word;
296 return (0);
297 }
298 }
299
300 return (1);
301 }
302
303 /*
304 * Compile a word into the dictionary that invokes the specified ficlParseStep
305 * function. It is up to the user (as usual in Forth) to make sure the stack
306 * preconditions are valid (there needs to be a counted string on top of the
307 * stack) before using the resulting word.
308 */
309 void
ficlSystemAddPrimitiveParseStep(ficlSystem * system,char * name,ficlParseStep pStep)310 ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name,
311 ficlParseStep pStep)
312 {
313 ficlDictionary *dictionary = system->dictionary;
314 ficlWord *word;
315 ficlCell c;
316
317 word = ficlDictionaryAppendPrimitive(dictionary, name,
318 ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
319
320 c.fn = (void (*)(void))pStep;
321 ficlDictionaryAppendCell(dictionary, c);
322 ficlSystemAddParseStep(system, word);
323 }
324
325 /*
326 * f i c l N e w V M
327 * Create a new virtual machine and link it into the system list
328 * of VMs for later cleanup by ficlTermSystem.
329 */
330 ficlVm *
ficlSystemCreateVm(ficlSystem * system)331 ficlSystemCreateVm(ficlSystem *system)
332 {
333 ficlVm *vm = ficlVmCreate(NULL, system->stackSize, system->stackSize);
334 vm->link = system->vmList;
335
336 memcpy(&(vm->callback), &(system->callback), sizeof (system->callback));
337 vm->callback.vm = vm;
338 vm->callback.system = system;
339
340 system->vmList = vm;
341 return (vm);
342 }
343
344 /*
345 * f i c l F r e e V M
346 * Removes the VM in question from the system VM list and deletes the
347 * memory allocated to it. This is an optional call, since ficlTermSystem
348 * will do this cleanup for you. This function is handy if you're going to
349 * do a lot of dynamic creation of VMs.
350 */
351 void
ficlSystemDestroyVm(ficlVm * vm)352 ficlSystemDestroyVm(ficlVm *vm)
353 {
354 ficlSystem *system = vm->callback.system;
355 ficlVm *pList = system->vmList;
356
357 FICL_VM_ASSERT(vm, vm != NULL);
358
359 if (system->vmList == vm) {
360 system->vmList = system->vmList->link;
361 } else
362 for (; pList != NULL; pList = pList->link) {
363 if (pList->link == vm) {
364 pList->link = vm->link;
365 break;
366 }
367 }
368
369 if (pList)
370 ficlVmDestroy(vm);
371 }
372
373 /*
374 * f i c l L o o k u p
375 * Look in the system dictionary for a match to the given name. If
376 * found, return the address of the corresponding ficlWord. Otherwise
377 * return NULL.
378 */
379 ficlWord *
ficlSystemLookup(ficlSystem * system,char * name)380 ficlSystemLookup(ficlSystem *system, char *name)
381 {
382 ficlString s;
383 FICL_STRING_SET_FROM_CSTRING(s, name);
384 return (ficlDictionaryLookup(system->dictionary, s));
385 }
386
387 /*
388 * f i c l G e t D i c t
389 * Returns the address of the system dictionary
390 */
391 ficlDictionary *
ficlSystemGetDictionary(ficlSystem * system)392 ficlSystemGetDictionary(ficlSystem *system)
393 {
394 return (system->dictionary);
395 }
396
397 /*
398 * f i c l G e t E n v
399 * Returns the address of the system environment space
400 */
401 ficlDictionary *
ficlSystemGetEnvironment(ficlSystem * system)402 ficlSystemGetEnvironment(ficlSystem *system)
403 {
404 return (system->environment);
405 }
406
407 /*
408 * f i c l G e t L o c
409 * Returns the address of the system locals dictionary. This dictionary is
410 * only used during compilation, and is shared by all VMs.
411 */
412 #if FICL_WANT_LOCALS
413 ficlDictionary *
ficlSystemGetLocals(ficlSystem * system)414 ficlSystemGetLocals(ficlSystem *system)
415 {
416 return (system->locals);
417 }
418 #endif
419
420 /*
421 * f i c l L o o k u p L o c
422 * Same as dictLookup, but looks in system locals dictionary first...
423 * Assumes locals dictionary has only one wordlist...
424 */
425 #if FICL_WANT_LOCALS
426 ficlWord *
ficlSystemLookupLocal(ficlSystem * system,ficlString name)427 ficlSystemLookupLocal(ficlSystem *system, ficlString name)
428 {
429 ficlWord *word = NULL;
430 ficlDictionary *dictionary = system->dictionary;
431 ficlHash *hash = ficlSystemGetLocals(system)->forthWordlist;
432 int i;
433 ficlUnsigned16 hashCode = ficlHashCode(name);
434
435 FICL_SYSTEM_ASSERT(system, hash);
436 FICL_SYSTEM_ASSERT(system, dictionary);
437
438 ficlDictionaryLock(dictionary, FICL_TRUE);
439 /*
440 * check the locals dictionary first...
441 */
442 word = ficlHashLookup(hash, name, hashCode);
443
444 /*
445 * If no joy, (!word) ------------------------------v
446 * iterate over the search list in the main dictionary
447 */
448 for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i) {
449 hash = dictionary->wordlists[i];
450 word = ficlHashLookup(hash, name, hashCode);
451 }
452
453 ficlDictionaryLock(dictionary, FICL_FALSE);
454 return (word);
455 }
456 #endif
457