1 /* Scheme In One Defun, but in C this time.
2
3 * COPYRIGHT (c) 1988-1994 BY *
4 * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
5 * See the source file SLIB.C for more information. *
6
7 */
8
9 /*
10
11 gjc@paradigm.com or gjc@mitech.com or gjc@world.std.com
12
13 Paradigm Associates Inc Phone: 617-492-6079
14 29 Putnam Ave, Suite 6
15 Cambridge, MA 02138
16
17 */
18
19 /***************************************************************/
20 /* This has been modified to act as an interface to siod as an */
21 /* embedded Lisp module. */
22 /* Also a (large) number of other functions have been added */
23 /* */
24 /* Alan W Black (awb@cstr.ed.ac.uk) 8th April 1996 */
25 /***************************************************************/
26 #include <cstdio>
27 #include "EST_unix.h"
28 #include <cstdlib>
29 #include <cstring>
30 #include "EST_String.h"
31 #include "EST_THash.h"
32 #include "EST_StringTrie.h"
33 #include "EST_cutils.h"
34 #include "EST_strcasecmp.h"
35 #include "siod.h"
36 #include "siodp.h"
37 #include "siodeditline.h"
38
39 #ifdef EST_SIOD_ENABLE_PYTHON
40 #include "slib_python.h"
41 #endif
42
43 extern "C" const char * repl_prompt;
44
45 template <> EST_String EST_THash<EST_String, EST_Regex *>::Dummy_Key = "DUMMY";
46 template <> EST_Regex *EST_THash<EST_String, EST_Regex *>::Dummy_Value = NULL;
47
48 #if defined(INSTANTIATE_TEMPLATES)
49 #include "../base_class/EST_THash.cc"
50
51 Instantiate_TStringHash_T(EST_Regex *, hash_string_regex)
52 #endif
53
54 static EST_TStringHash<EST_Regex *> regexes(100);
55
siod_init(int heap_size)56 int siod_init(int heap_size)
57 {
58 /* Initialize siod */
59 int actual_heap_size;
60
61 if (heap_size == -1) // unspecified by user
62 {
63 char *char_heap_size=getenv("SIODHEAPSIZE");
64 if ((char_heap_size == 0) ||
65 (atoi(char_heap_size) < 1000))
66 actual_heap_size=ACTUAL_DEFAULT_HEAP_SIZE;
67 else
68 actual_heap_size=atoi(char_heap_size);
69 }
70 else
71 actual_heap_size = heap_size;
72
73 init_storage(actual_heap_size);
74 init_subrs();
75
76 #ifdef EST_SIOD_ENABLE_PYTHON
77 init_subrs_python();
78 #endif
79
80 return 0;
81 }
82
siod_tidy_up()83 void siod_tidy_up()
84 {
85 #ifdef EST_SIOD_ENABLE_PYTHON
86 python_tidy_up();
87 #endif
88
89 close_open_files();
90 }
91
siod_get_lval(const char * name,const char * message)92 LISP siod_get_lval(const char *name,const char *message)
93 {
94 // returns value of variable name. If not set gives an error
95 LISP iii, rval=NIL;
96
97 iii = rintern(name);
98
99 // value or NIL if unset
100 if (symbol_boundp(iii,current_env) == NIL)
101 {
102 if (message != NULL)
103 err(message,iii);
104 }
105 else
106 rval = symbol_value(iii, current_env);
107
108 return rval;
109 }
110
siod_set_lval(const char * name,LISP val)111 LISP siod_set_lval(const char *name,LISP val)
112 {
113 // set variable name to val
114 LISP iii, rval;
115
116 iii = rintern(name);
117
118 rval = setvar(iii,val,current_env);
119
120 return rval;
121 }
122
siod_assoc_str(const char * key,LISP alist)123 LISP siod_assoc_str(const char *key,LISP alist)
124 {
125 // assoc without going through LISP atoms
126 // made get_c_string inline for optimization
127 LISP l,lc,lcc;
128
129 for (l=alist; CONSP(l); l=CDR(l))
130 {
131 lc = CAR(l);
132 if (CONSP(lc))
133 {
134 lcc = CAR(lc);
135 if (NULLP(lcc)) continue;
136 else if TYPEP(lcc,tc_symbol)
137 {
138 if (strcmp(key,PNAME(lcc))==0)
139 return lc;
140 }
141 else if TYPEP(lcc,tc_flonum)
142 {
143 if (FLONMPNAME(lcc) == NULL)
144 {
145 char b[TKBUFFERN];
146 sprintf(b,"%g",FLONM(lcc));
147 FLONMPNAME(lcc) = (char *)must_malloc(strlen(b)+1);
148 sprintf(FLONMPNAME(lcc),"%s",b);
149 }
150 if (strcmp(key,FLONMPNAME(lcc))==0)
151 return lc;
152 }
153 else if TYPEP(lcc,tc_string)
154 {
155 if (strcmp(key,lcc->storage_as.string.data)==0)
156 return lc;
157 }
158 else
159 continue;
160 }
161 }
162 return NIL;
163 }
164
siod_member_str(const char * key,LISP list)165 LISP siod_member_str(const char *key,LISP list)
166 {
167 // member without going through LISP atoms
168 LISP l;
169
170 for (l=list; CONSP(l); l=CDR(l))
171 if (strcmp(key,get_c_string(CAR(l))) == 0)
172 return l;
173
174 return NIL;
175 }
176
siod_regex_member_str(const EST_String & key,LISP list)177 LISP siod_regex_member_str(const EST_String &key,LISP list)
178 {
179 // Check the regexs in LIST against key
180 LISP l;
181
182 for (l=list; CONSP(l); l=CDR(l))
183 if (key.matches(make_regex(get_c_string(CAR(l)))))
184 return l;
185
186 return NIL;
187 }
188
siod_member_int(const int key,LISP list)189 LISP siod_member_int(const int key,LISP list)
190 {
191 // member without going through LISP atoms
192 LISP l;
193
194 for (l=list; CONSP(l); l=CDR(l))
195 if (key == get_c_int(CAR(l)))
196 return l;
197 return NIL;
198 }
199
siod_llength(LISP list)200 int siod_llength(LISP list)
201 {
202 // length of string;
203 int len;
204 LISP l;
205
206 for (len=0,l=list; CONSP(l); l=CDR(l),len++);
207
208 return len;
209
210 }
211
siod_nth(int n,LISP list)212 LISP siod_nth(int n,LISP list)
213 {
214 // nth member -- first member is 0;
215 int i;
216 LISP l;
217
218 for (i=0,l=list; CONSP(l); l=CDR(l),i++)
219 if (i == n)
220 return car(l);
221
222 return NIL;
223
224 }
225
siod_atomic_list(LISP list)226 int siod_atomic_list(LISP list)
227 {
228 // TRUE is list only contains atoms
229 LISP p;
230
231 for (p=list; p != NIL; p=cdr(p))
232 if (CONSP(car(p)))
233 return FALSE;
234
235 return TRUE;
236 }
237
siod_eof(LISP item)238 int siod_eof(LISP item)
239 {
240 // TRUE if item is what siod denotes as eof
241 if (CONSP(item) &&
242 (cdr(item) == NIL) &&
243 (SYMBOLP(car(item))) &&
244 (strcmp("eof",get_c_string(car(item))) == 0))
245 return TRUE;
246 else
247 return FALSE;
248 }
249
quote(LISP l)250 LISP quote(LISP l)
251 {
252 // Add quote round a Lisp expression
253 return cons(rintern("quote"),cons(l,NIL));
254 }
255
siod_last(LISP list)256 LISP siod_last(LISP list)
257 {
258 LISP l;
259
260 if ((list == NIL) || (NCONSP(list)))
261 return NIL;
262 else
263 {
264 for (l=list; cdr(l) != NIL; l=cdr(l));
265 return l;
266 }
267 }
268
get_param_int(const char * name,LISP params,int defval)269 int get_param_int(const char *name, LISP params, int defval)
270 {
271 // Look up name in params and return value if present or
272 // defval if not present
273 LISP pair;
274
275 pair = siod_assoc_str(name,params);
276
277 if (pair == NIL)
278 return defval;
279 else if FLONUMP(car(cdr(pair)))
280 return (int)FLONM(car(cdr(pair)));
281 else
282 {
283 cerr << "param " << name << " not of type int" << endl;
284 err("",NIL);
285 return -1;
286 }
287
288 }
289
get_param_float(const char * name,LISP params,float defval)290 float get_param_float(const char *name, LISP params, float defval)
291 {
292 // Look up name in params and return value if present or
293 // defval if not present
294 LISP pair;
295
296 pair = siod_assoc_str(name,params);
297
298 if (pair == NIL)
299 return defval;
300 else if (FLONUMP(car(cdr(pair))))
301 return (float)FLONM(car(cdr(pair)));
302 else
303 {
304 cerr << "param " << name << " not of type float" << endl;
305 err("",NIL);
306 return -1;
307 }
308
309 }
310
get_param_str(const char * name,LISP params,const char * defval)311 const char *get_param_str(const char *name, LISP params, const char *defval)
312 {
313 // Look up name in params and return value if present or
314 // defval if not present
315 LISP pair;
316
317 pair = siod_assoc_str(name,params);
318
319 if (pair == NIL)
320 return defval;
321 else
322 return get_c_string(car(cdr(pair)));
323 }
324
get_param_lisp(const char * name,LISP params,LISP defval)325 LISP get_param_lisp(const char *name, LISP params, LISP defval)
326 {
327 // Look up name in params and return value if present or
328 // defval if not present
329 LISP pair;
330
331 pair = siod_assoc_str(name,params);
332
333 if (pair == NIL)
334 return defval;
335 else
336 return car(cdr(pair));
337 }
338
make_param_str(const char * name,const char * val)339 LISP make_param_str(const char *name,const char *val)
340 {
341 return cons(rintern(name),cons(rintern(val),NIL));
342 }
343
make_param_int(const char * name,int val)344 LISP make_param_int(const char *name, int val)
345 {
346 return cons(rintern(name),cons(flocons(val),NIL));
347 }
348
make_param_float(const char * name,float val)349 LISP make_param_float(const char *name, float val)
350 {
351 return cons(rintern(name),cons(flocons(val),NIL));
352 }
353
make_param_lisp(const char * name,LISP val)354 LISP make_param_lisp(const char *name,LISP val)
355 {
356 return cons(rintern(name),cons(val,NIL));
357 }
358
make_regex(const char * r)359 EST_Regex &make_regex(const char *r)
360 {
361 // Return pointer to existing regex if its already been created
362 // otherwise create a new one for this r.
363 EST_Regex *rx;
364 EST_String sr = r;
365 int found;
366
367 rx = regexes.val(sr,found);
368 if (!found)
369 {
370 rx = new EST_Regex(r);
371 regexes.add_item(sr,rx);
372 }
373
374 return *rx;
375 }
376
apply_hooks(LISP hooks,LISP arg)377 LISP apply_hooks(LISP hooks,LISP arg)
378 {
379 // Apply each function in hooks to arg returning value from
380 // final application (or arg itself)
381 LISP h,r;
382
383 r = arg;
384
385 if (hooks && (!CONSP(hooks))) // singleton
386 r = leval(cons(hooks,cons(quote(arg),NIL)),NIL);
387 else
388 for (h=hooks; h != NIL; h=cdr(h))
389 r = leval(cons(car(h),cons(quote(arg),NIL)),NIL);
390 return r;
391 }
392
apply_hooks_right(LISP hooks,LISP args)393 LISP apply_hooks_right(LISP hooks,LISP args)
394 {
395 // The above version neither quotes its arguments properly of deals
396 // with lists of arguments so here's a better one
397 // Apply each function in hooks to arg returning value from
398 // final application (or arg itself)
399 LISP h,r;
400
401 if (hooks == NIL)
402 r = args;
403 else if (!CONSP(hooks)) // singleton
404 r = apply(hooks,args);
405 else
406 for (r=args,h=hooks; h != NIL; h=cdr(h))
407 r = apply(car(h),r);
408 return r;
409 }
410
apply(LISP func,LISP args)411 LISP apply(LISP func,LISP args)
412 {
413 LISP qa,a;
414
415 for (qa=NIL,a=args; a; a=cdr(a))
416 qa = cons(quote(car(a)),qa);
417 return leval(cons(func,reverse(qa)),NIL);
418 }
419
stringexplode(const char * str)420 LISP stringexplode(const char *str)
421 {
422 // Explode character string into list of symbols one for each char
423 LISP l=NIL;
424 unsigned int i;
425 char id[2];
426 id[1] = '\0';
427
428 for (i=0; i < strlen(str); i++)
429 {
430 id[0] = str[i];
431 l = cons(rintern(id),l);
432 }
433
434 return reverse(l);
435 }
436
437 /* Editline completion functions */
438
siod_variable_generator(char * text,int length)439 char **siod_variable_generator(char *text,int length)
440 {
441 LISP l,lmatches;
442 const char *name;
443 char **matches = NULL;
444 int i;
445
446 /* Return the next name which partially matches from the command list. */
447 for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
448 {
449 if (VCELL(car(l)) == NIL) continue;
450 switch(TYPE(VCELL(CAR(l))))
451 {
452 case tc_subr_0:
453 case tc_subr_1:
454 case tc_subr_2:
455 case tc_subr_3:
456 case tc_subr_4:
457 case tc_lsubr:
458 case tc_fsubr:
459 case tc_msubr:
460 case tc_closure:
461 continue;
462 default:
463 /* only return names of nonfunctions (sometimes too restrictive) */
464 name = PNAME(CAR(l));
465 if (strncmp(name, text, length) == 0)
466 lmatches = cons(CAR(l),lmatches);
467 }
468 }
469
470 /* Need to return the matches in a char** */
471 matches = walloc(char *,siod_llength(lmatches)+1);
472 for (l=lmatches,i=0; l; l=cdr(l),i++)
473 matches[i] = wstrdup(PNAME(car(l)));
474 matches[i] = NULL;
475
476 return matches;
477 }
478
siod_command_generator(char * text,int length)479 char **siod_command_generator (char *text,int length)
480 {
481 LISP l,lmatches;
482 const char *name;
483 char **matches = NULL;
484 int i;
485
486 /* Return the next name which partially matches from the command list. */
487 for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
488 {
489 if (VCELL(car(l)) == NIL) continue;
490 switch(TYPE(VCELL(CAR(l))))
491 {
492 case tc_subr_0:
493 case tc_subr_1:
494 case tc_subr_2:
495 case tc_subr_3:
496 case tc_subr_4:
497 case tc_lsubr:
498 case tc_fsubr:
499 case tc_msubr:
500 case tc_closure:
501 /* only return names of functions */
502 name = PNAME(CAR(l));
503 if (strncmp(name, text, length) == 0)
504 lmatches = cons(CAR(l),lmatches);
505 default: continue;
506 }
507 }
508
509 /* Need to return the matches in a char** */
510 matches = walloc(char *,siod_llength(lmatches)+1);
511 for (l=lmatches,i=0; l; l=cdr(l),i++)
512 matches[i] = wstrdup(PNAME(car(l)));
513 matches[i] = NULL;
514
515 return matches;
516 }
517
siod_list_to_strlist(LISP l,EST_StrList & a)518 void siod_list_to_strlist(LISP l, EST_StrList &a)
519 {
520 // copy l into a
521 LISP b;
522
523 a.clear();
524
525 for (b=l; b != NIL; b=cdr(b))
526 a.append(get_c_string(car(b)));
527
528 }
529
siod_strlist_to_list(EST_StrList & a)530 LISP siod_strlist_to_list(EST_StrList &a)
531 {
532 // copy a into l
533 LISP b=NIL;;
534 EST_Litem *p;
535
536 for (p=a.head(); p != 0; p=p->next())
537 b = cons(rintern(a(p)),b);
538
539 return reverse(b);
540 }
541
542