xref: /illumos-gate/usr/src/common/ficl/system.c (revision c0bb4f73)
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