1 /*******************************************************************
2 ** p r e f i x . c
3 ** Forth Inspired Command Language
4 ** Parser extensions for Ficl
5 ** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu)
6 ** Created: April 2001
7 ** $Id: prefix.c,v 1.8 2010/09/13 18:43:04 asau Exp $
8 *******************************************************************/
9 /*
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
12 **
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
14 **
15 ** I am interested in hearing from anyone who uses Ficl. If you have
16 ** a problem, a success story, a defect, an enhancement request, or
17 ** if you would like to contribute to the Ficl release, please
18 ** contact me by email at the address above.
19 **
20 ** L I C E N S E and D I S C L A I M E R
21 **
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
24 ** are met:
25 ** 1. Redistributions of source code must retain the above copyright
26 ** notice, this list of conditions and the following disclaimer.
27 ** 2. Redistributions in binary form must reproduce the above copyright
28 ** notice, this list of conditions and the following disclaimer in the
29 ** documentation and/or other materials provided with the distribution.
30 **
31 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 ** SUCH DAMAGE.
42 */
43
44 /*-
45 * Adapted to work with FTH
46 *
47 * Copyright (c) 2004-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
48 * All rights reserved.
49 *
50 * Redistribution and use in source and binary forms, with or without
51 * modification, are permitted provided that the following conditions
52 * are met:
53 * 1. Redistributions of source code must retain the above copyright
54 * notice, this list of conditions and the following disclaimer.
55 * 2. Redistributions in binary form must reproduce the above copyright
56 * notice, this list of conditions and the following disclaimer in the
57 * documentation and/or other materials provided with the distribution.
58 *
59 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
60 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
61 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
62 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
63 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
64 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
65 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
66 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
67 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
68 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
69 * SUCH DAMAGE.
70 *
71 * @(#)prefix.c 1.29 11/18/19
72 */
73
74 #if defined(HAVE_CONFIG_H)
75 #include "config.h"
76 #endif
77
78 #include <string.h>
79 #include <ctype.h>
80 #include "ficl.h"
81
82 #include "fth.h"
83 #include "utils.h"
84
85 /*
86 ** (jws) revisions:
87 ** A prefix is a word in a dedicated wordlist (name stored in list_name below)
88 ** that is searched in a special way by the prefix parse step. When a prefix
89 ** matches the beginning of an incoming token, push the non-prefix part of the
90 ** token back onto the input stream and execute the prefix code.
91 **
92 ** The parse step is called ficlParsePrefix.
93 ** Storing prefix entries in the dictionary greatly simplifies
94 ** the process of matching and dispatching prefixes, avoids the
95 ** need to clean up a dynamically allocated prefix list when the system
96 ** goes away, but still allows prefixes to be allocated at runtime.
97 */
98
99 static char list_name[] = "<prefixes>";
100
101 /**************************************************************************
102 ** f i c l P a r s e P r e f i x
103 ** This is the parse step for prefixes - it checks an incoming word
104 ** to see if it starts with a prefix, and if so runs the corresponding
105 ** code against the remainder of the word and returns true.
106 **************************************************************************/
ficlVmParsePrefix(ficlVm * vm,ficlString s)107 int ficlVmParsePrefix(ficlVm *vm, ficlString s)
108 {
109 ficlUnsigned i;
110 ficlHash *hash;
111 ficlWord *word = ficlSystemLookup(vm->callback.system, list_name);
112
113 /*
114 ** Make sure we found the prefix dictionary - otherwise silently fail
115 ** If forth-wordlist is not in the search order, we won't find the prefixes.
116 */
117 if (word == NULL)
118 return FICL_FALSE;
119
120 hash = (ficlHash *)CELL_VOIDP_REF(word->param);
121 /*
122 ** Walk the list looking for a match with the beginning of the incoming token
123 */
124 for (i = 0; i < hash->size; i++)
125 {
126 word = hash->table[i];
127
128 while (word != NULL)
129 {
130 ficlUnsigned n = word->length;
131 /*
132 ** If we find a match, adjust the TIB to give back the non-prefix characters
133 ** and execute the prefix word.
134 */
135 if (ficlStrincmp(FICL_STRING_GET_POINTER(s), word->name, n) == 0)
136 {
137 /* (sadler) fixed off-by-one error when the token has no trailing space in the TIB */
138 ficlVmSetTibIndex(vm, s.text + n - vm->tib.text);
139 ficlVmExecuteWord(vm, word);
140 return FICL_TRUE;
141 }
142 word = word->link;
143 }
144 }
145 return FICL_FALSE;
146 }
147
ficlPrimitiveTempBase(ficlVm * vm)148 static void ficlPrimitiveTempBase(ficlVm *vm)
149 {
150 ficlUnsigned oldbase = vm->base;
151 ficlString number = ficlVmGetWord0(vm);
152 ficlUnsigned base = ficlStackPopUnsigned(vm->dataStack);
153 int status;
154
155 vm->base = base;
156 status = ficl_parse_number(vm, number);
157 if (!status)
158 status = ficl_parse_bignum(vm, number);
159 vm->base = oldbase;
160
161 if (!status)
162 ficlVmThrowError(vm, "%.*s not recognized", (int)number.length, number.text);
163 }
164
165 /*
166 *
167 * Moved from examples/fth-lib/prefix.fr to ficl/prefix.c.
168 * See note XXX in ficlSystemCompilePrefix() below for an explanation.
169 */
170 static int save_current_count;
171 static ficlHash *save_current;
172
173 /*
174 * : start-prefixes ( -- )
175 * get-current save-current !
176 * <prefixes> set-current
177 * ;
178 */
179 static void
ficl_start_prefixes(ficlVm * vm)180 ficl_start_prefixes(ficlVm *vm)
181 {
182 ficlWord *word;
183 ficlDictionary *dict;
184
185 if (save_current_count != 0)
186 fth_throw(FTH_WORD_LIST_ERROR,
187 "prefix dictionary \"%s\" already called", list_name);
188 save_current_count++;
189 dict = ficlVmGetDictionary(vm);
190 save_current = dict->compilationWordlist;
191 word = ficlSystemLookup(vm->callback.system, list_name);
192 if (word != NULL)
193 dict->compilationWordlist = (ficlHash *)FICL_WORD_PARAM(word);
194 else
195 fth_throw(FTH_WORD_LIST_ERROR,
196 "prefix dictionary \"%s\" not found", list_name);
197 }
198
199 /*
200 * : end-prefixes ( -- )
201 * save-current @ set-current
202 * ;
203 */
204 static void
ficl_end_prefixes(ficlVm * vm)205 ficl_end_prefixes(ficlVm *vm)
206 {
207 if (save_current_count != 1)
208 fth_throw(FTH_WORD_LIST_ERROR,
209 "prefix dictionary \"%s\" not called before", list_name);
210 save_current_count--;
211 ficlVmGetDictionary(vm)->compilationWordlist = save_current;
212 }
213
214 /**************************************************************************
215 ** f i c l C o m p i l e P r e f i x
216 ** Build prefix support into the dictionary and the parser
217 ** Note: since prefixes always execute, they are effectively IMMEDIATE.
218 ** If they need to generate code in compile state you must add
219 ** this code explicitly.
220 **************************************************************************/
ficlSystemCompilePrefix(ficlSystem * system)221 void ficlSystemCompilePrefix(ficlSystem *system)
222 {
223 ficlDictionary *dict = ficlSystemGetDictionary(system);
224 ficlHash *hash;
225
226 /*
227 ** Create a named wordlist for prefixes to reside in...
228 ** Since we're doing a special kind of search, make it
229 ** a single bucket hashtable - hashing does not help here.
230 */
231 hash = ficlDictionaryCreateWordlist(dict, 1);
232 hash->name = list_name;
233 ficlDictionaryAppendPointerConstant(dict, list_name, hash);
234
235 /*
236 ** Put __tempbase in the forth-wordlist
237 */
238 FICL_PRIM(dict, "__tempbase", ficlPrimitiveTempBase);
239
240 /*
241 * XXX start-prefixes, end-prefixes [ms]
242 * Moved from examples/fth-lib/prefix.fr to ficl/prefix.c.
243 * If written in Forth, OpenBSD raises from time to time a SIGBUS
244 * signal before setting the prefix wordlist.
245 */
246 save_current_count = 0;
247 FICL_PRIM(dict, "start-prefixes", ficl_start_prefixes);
248 FICL_PRIM(dict, "end-prefixes", ficl_end_prefixes);
249
250 /*
251 ** If you want to add some prefixes at compilation-time, copy this
252 ** line to the top of this function:
253 **
254 ficlHash *oldCompilationWordlist;
255
256 **
257 ** then copy this code to the bottom, just above the return:
258 **
259
260 oldCompilationWordlist = dict->compilationWordlist;
261 dict->compilationWordlist = hash;
262 ficlDictionarySetPrimitive(dict, YOUR WORD HERE, FICL_WORD_DEFAULT);
263 dict->compilationWordlist = oldCompilationWordlist;
264
265 **
266 ** and substitute in your own actual calls to ficlDictionarySetPrimitive() as needed.
267 **
268 ** Or--better yet--do it in your own code, so you don't have to re-modify the Ficl
269 ** source code every time we cut a new release!
270 */
271 }
272