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 (void) ficlDictionarySet2Constant(environment, "ficl-version",
87 combined);
88 (void) ficlDictionarySetConstant(environment, "ficl-robust",
89 FICL_ROBUST);
90 }
91
92 /*
93 * f i c l I n i t S y s t e m
94 * Binds a global dictionary to the interpreter system.
95 * You specify the address and size of the allocated area.
96 * After that, Ficl manages it.
97 * First step is to set up the static pointers to the area.
98 * Then write the "precompiled" portion of the dictionary in.
99 * The dictionary needs to be at least large enough to hold the
100 * precompiled part. Try 1K cells minimum. Use "words" to find
101 * out how much of the dictionary is used at any time.
102 */
103 ficlSystem *
ficlSystemCreate(ficlSystemInformation * fsi)104 ficlSystemCreate(ficlSystemInformation *fsi)
105 {
106 ficlInteger dictionarySize;
107 ficlInteger environmentSize;
108 ficlInteger stackSize;
109 ficlSystem *system;
110 ficlCallback callback;
111 ficlSystemInformation fauxInfo;
112 ficlDictionary *environment;
113
114 if (fsi == NULL) {
115 fsi = &fauxInfo;
116 ficlSystemInformationInitialize(fsi);
117 }
118
119 callback.context = fsi->context;
120 callback.textOut = fsi->textOut;
121 callback.errorOut = fsi->errorOut;
122 callback.system = NULL;
123 callback.vm = NULL;
124
125 FICL_ASSERT(&callback, sizeof (ficlInteger) >= sizeof (void *));
126 FICL_ASSERT(&callback, sizeof (ficlUnsigned) >= sizeof (void *));
127 #if (FICL_WANT_FLOAT)
128 FICL_ASSERT(&callback, sizeof (ficlFloat) <= sizeof (ficlInteger));
129 #endif
130
131 system = ficlMalloc(sizeof (ficlSystem));
132
133 FICL_ASSERT(&callback, system);
134
135 memset(system, 0, sizeof (ficlSystem));
136
137 dictionarySize = fsi->dictionarySize;
138 if (dictionarySize <= 0)
139 dictionarySize = FICL_DEFAULT_DICTIONARY_SIZE;
140
141 environmentSize = fsi->environmentSize;
142 if (environmentSize <= 0)
143 environmentSize = FICL_DEFAULT_ENVIRONMENT_SIZE;
144
145 stackSize = fsi->stackSize;
146 if (stackSize < FICL_DEFAULT_STACK_SIZE)
147 stackSize = FICL_DEFAULT_STACK_SIZE;
148
149 system->dictionary = ficlDictionaryCreateHashed(system,
150 (unsigned)dictionarySize, FICL_HASH_SIZE);
151 system->dictionary->forthWordlist->name = "forth-wordlist";
152
153 environment = ficlDictionaryCreate(system, (unsigned)environmentSize);
154 system->environment = environment;
155 system->environment->forthWordlist->name = "environment";
156
157 system->callback.textOut = fsi->textOut;
158 system->callback.errorOut = fsi->errorOut;
159 system->callback.context = fsi->context;
160 system->callback.system = system;
161 system->callback.vm = NULL;
162 system->stackSize = stackSize;
163
164 #if FICL_WANT_LOCALS
165 /*
166 * The locals dictionary is only searched while compiling,
167 * but this is where speed is most important. On the other
168 * hand, the dictionary gets emptied after each use of locals
169 * The need to balance search speed with the cost of the 'empty'
170 * operation led me to select a single-threaded list...
171 */
172 system->locals = ficlDictionaryCreate(system,
173 (unsigned)FICL_MAX_LOCALS * FICL_CELLS_PER_WORD);
174 #endif /* FICL_WANT_LOCALS */
175
176 /*
177 * Build the precompiled dictionary and load softwords. We need
178 * a temporary VM to do this - ficlNewVM links one to the head of
179 * the system VM list. ficlCompilePlatform (defined in win32.c,
180 * for example) adds platform specific words.
181 */
182 ficlSystemCompileCore(system);
183 ficlSystemCompilePrefix(system);
184
185 #if FICL_WANT_FLOAT
186 ficlSystemCompileFloat(system);
187 #endif /* FICL_WANT_FLOAT */
188
189 #if FICL_WANT_PLATFORM
190 ficlSystemCompilePlatform(system);
191 #endif /* FICL_WANT_PLATFORM */
192
193 ficlSystemSetVersion(system);
194
195 /*
196 * Establish the parse order. Note that prefixes precede numbers -
197 * this allows constructs like "0b101010" which might parse as a
198 * hex value otherwise.
199 */
200 ficlSystemAddPrimitiveParseStep(system, "?word", ficlVmParseWord);
201 ficlSystemAddPrimitiveParseStep(system, "?prefix", ficlVmParsePrefix);
202 ficlSystemAddPrimitiveParseStep(system, "?number", ficlVmParseNumber);
203 #if FICL_WANT_FLOAT
204 ficlSystemAddPrimitiveParseStep(system, "?float",
205 ficlVmParseFloatNumber);
206 #endif
207
208 /*
209 * Now create a temporary VM to compile the softwords. Since all VMs
210 * are linked into the vmList of ficlSystem, we don't have to pass
211 * the VM to ficlCompileSoftCore -- it just hijacks whatever it finds
212 * in the VM list. Ficl 2.05: vmCreate no longer depends on the
213 * presence of INTERPRET in the dictionary, so a VM can be created
214 * before the dictionary is built. It just can't do much...
215 */
216 (void) ficlSystemCreateVm(system);
217 #define ADD_COMPILE_FLAG(name) \
218 (void) ficlDictionarySetConstant(environment, #name, name)
219 ADD_COMPILE_FLAG(FICL_WANT_LZ4_SOFTCORE);
220 ADD_COMPILE_FLAG(FICL_WANT_FILE);
221 ADD_COMPILE_FLAG(FICL_WANT_FLOAT);
222 ADD_COMPILE_FLAG(FICL_WANT_DEBUGGER);
223 ADD_COMPILE_FLAG(FICL_WANT_EXTENDED_PREFIX);
224 ADD_COMPILE_FLAG(FICL_WANT_USER);
225 ADD_COMPILE_FLAG(FICL_WANT_LOCALS);
226 ADD_COMPILE_FLAG(FICL_WANT_OOP);
227 ADD_COMPILE_FLAG(FICL_WANT_SOFTWORDS);
228 ADD_COMPILE_FLAG(FICL_WANT_MULTITHREADED);
229 ADD_COMPILE_FLAG(FICL_WANT_OPTIMIZE);
230 ADD_COMPILE_FLAG(FICL_WANT_VCALL);
231
232 ADD_COMPILE_FLAG(FICL_PLATFORM_ALIGNMENT);
233
234 ADD_COMPILE_FLAG(FICL_ROBUST);
235
236 #define ADD_COMPILE_STRING(name) \
237 (void) ficlDictionarySetConstantString(environment, #name, name)
238 ADD_COMPILE_STRING(FICL_PLATFORM_ARCHITECTURE);
239 ADD_COMPILE_STRING(FICL_PLATFORM_OS);
240
241 ficlSystemCompileSoftCore(system);
242 ficlSystemDestroyVm(system->vmList);
243
244 if (ficlSystemGlobal == NULL)
245 ficlSystemGlobal = system;
246
247 return (system);
248 }
249
250 /*
251 * f i c l T e r m S y s t e m
252 * Tear the system down by deleting the dictionaries and all VMs.
253 * This saves you from having to keep track of all that stuff.
254 */
255 void
ficlSystemDestroy(ficlSystem * system)256 ficlSystemDestroy(ficlSystem *system)
257 {
258 if (system->dictionary)
259 ficlDictionaryDestroy(system->dictionary);
260 system->dictionary = NULL;
261
262 if (system->environment)
263 ficlDictionaryDestroy(system->environment);
264 system->environment = NULL;
265
266 #if FICL_WANT_LOCALS
267 if (system->locals)
268 ficlDictionaryDestroy(system->locals);
269 system->locals = NULL;
270 #endif
271
272 while (system->vmList != NULL) {
273 ficlVm *vm = system->vmList;
274 system->vmList = system->vmList->link;
275 ficlVmDestroy(vm);
276 }
277
278 if (ficlSystemGlobal == system)
279 ficlSystemGlobal = NULL;
280
281 ficlFree(system);
282 system = NULL;
283 }
284
285 /*
286 * f i c l A d d P a r s e S t e p
287 * Appends a parse step function to the end of the parse list (see
288 * ficlParseStep notes in ficl.h for details). Returns 0 if successful,
289 * nonzero if there's no more room in the list.
290 */
291 int
ficlSystemAddParseStep(ficlSystem * system,ficlWord * word)292 ficlSystemAddParseStep(ficlSystem *system, ficlWord *word)
293 {
294 int i;
295 for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
296 if (system->parseList[i] == NULL) {
297 system->parseList[i] = word;
298 return (0);
299 }
300 }
301
302 return (1);
303 }
304
305 /*
306 * Compile a word into the dictionary that invokes the specified ficlParseStep
307 * function. It is up to the user (as usual in Forth) to make sure the stack
308 * preconditions are valid (there needs to be a counted string on top of the
309 * stack) before using the resulting word.
310 */
311 void
ficlSystemAddPrimitiveParseStep(ficlSystem * system,char * name,ficlParseStep pStep)312 ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name,
313 ficlParseStep pStep)
314 {
315 ficlDictionary *dictionary = system->dictionary;
316 ficlWord *word;
317 ficlCell c;
318
319 word = ficlDictionaryAppendPrimitive(dictionary, name,
320 ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
321
322 c.fn = (void (*)(void))pStep;
323 ficlDictionaryAppendCell(dictionary, c);
324 (void) ficlSystemAddParseStep(system, word);
325 }
326
327 /*
328 * f i c l N e w V M
329 * Create a new virtual machine and link it into the system list
330 * of VMs for later cleanup by ficlTermSystem.
331 */
332 ficlVm *
ficlSystemCreateVm(ficlSystem * system)333 ficlSystemCreateVm(ficlSystem *system)
334 {
335 ficlVm *vm = ficlVmCreate(NULL, system->stackSize, system->stackSize);
336 vm->link = system->vmList;
337
338 memcpy(&(vm->callback), &(system->callback), sizeof (system->callback));
339 vm->callback.vm = vm;
340 vm->callback.system = system;
341
342 system->vmList = vm;
343 return (vm);
344 }
345
346 /*
347 * f i c l F r e e V M
348 * Removes the VM in question from the system VM list and deletes the
349 * memory allocated to it. This is an optional call, since ficlTermSystem
350 * will do this cleanup for you. This function is handy if you're going to
351 * do a lot of dynamic creation of VMs.
352 */
353 void
ficlSystemDestroyVm(ficlVm * vm)354 ficlSystemDestroyVm(ficlVm *vm)
355 {
356 ficlSystem *system = vm->callback.system;
357 ficlVm *pList = system->vmList;
358
359 FICL_VM_ASSERT(vm, vm != NULL);
360
361 if (system->vmList == vm) {
362 system->vmList = system->vmList->link;
363 } else
364 for (; pList != NULL; pList = pList->link) {
365 if (pList->link == vm) {
366 pList->link = vm->link;
367 break;
368 }
369 }
370
371 if (pList)
372 ficlVmDestroy(vm);
373 }
374
375 /*
376 * f i c l L o o k u p
377 * Look in the system dictionary for a match to the given name. If
378 * found, return the address of the corresponding ficlWord. Otherwise
379 * return NULL.
380 */
381 ficlWord *
ficlSystemLookup(ficlSystem * system,char * name)382 ficlSystemLookup(ficlSystem *system, char *name)
383 {
384 ficlString s;
385 FICL_STRING_SET_FROM_CSTRING(s, name);
386 return (ficlDictionaryLookup(system->dictionary, s));
387 }
388
389 /*
390 * f i c l G e t D i c t
391 * Returns the address of the system dictionary
392 */
393 ficlDictionary *
ficlSystemGetDictionary(ficlSystem * system)394 ficlSystemGetDictionary(ficlSystem *system)
395 {
396 return (system->dictionary);
397 }
398
399 /*
400 * f i c l G e t E n v
401 * Returns the address of the system environment space
402 */
403 ficlDictionary *
ficlSystemGetEnvironment(ficlSystem * system)404 ficlSystemGetEnvironment(ficlSystem *system)
405 {
406 return (system->environment);
407 }
408
409 /*
410 * f i c l G e t L o c
411 * Returns the address of the system locals dictionary. This dictionary is
412 * only used during compilation, and is shared by all VMs.
413 */
414 #if FICL_WANT_LOCALS
415 ficlDictionary *
ficlSystemGetLocals(ficlSystem * system)416 ficlSystemGetLocals(ficlSystem *system)
417 {
418 return (system->locals);
419 }
420 #endif
421
422 /*
423 * f i c l L o o k u p L o c
424 * Same as dictLookup, but looks in system locals dictionary first...
425 * Assumes locals dictionary has only one wordlist...
426 */
427 #if FICL_WANT_LOCALS
428 ficlWord *
ficlSystemLookupLocal(ficlSystem * system,ficlString name)429 ficlSystemLookupLocal(ficlSystem *system, ficlString name)
430 {
431 ficlWord *word = NULL;
432 ficlDictionary *dictionary = system->dictionary;
433 ficlHash *hash = ficlSystemGetLocals(system)->forthWordlist;
434 int i;
435 ficlUnsigned16 hashCode = ficlHashCode(name);
436
437 FICL_SYSTEM_ASSERT(system, hash);
438 FICL_SYSTEM_ASSERT(system, dictionary);
439
440 ficlDictionaryLock(dictionary, FICL_TRUE);
441 /*
442 * check the locals dictionary first...
443 */
444 word = ficlHashLookup(hash, name, hashCode);
445
446 /*
447 * If no joy, (!word) ------------------------------v
448 * iterate over the search list in the main dictionary
449 */
450 for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i) {
451 hash = dictionary->wordlists[i];
452 word = ficlHashLookup(hash, name, hashCode);
453 }
454
455 ficlDictionaryLock(dictionary, FICL_FALSE);
456 return (word);
457 }
458 #endif
459