Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- /* Scheme In One Defun, but in C this time.
- * COPYRIGHT (c) 1988-1994 BY *
- * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
- * See the source file SLIB.C for more information. *
- */
- /*
- gjc@paradigm.com or gjc@mitech.com or gjc@world.std.com
- Paradigm Associates Inc Phone: 617-492-6079
- 29 Putnam Ave, Suite 6
- Cambridge, MA 02138
- */
- /***************************************************************/
- /* This has been modified to act as an interface to siod as an */
- /* embedded Lisp module. */
- /* Also a (large) number of other functions have been added */
- /* */
- /* Alan W Black (awb@cstr.ed.ac.uk) 8th April 1996 */
- /***************************************************************/
- #include <cstdio>
- #include "EST_unix.h"
- #include <cstdlib>
- #include <cstring>
- #include "EST_String.h"
- #include "EST_THash.h"
- #include "EST_StringTrie.h"
- #include "EST_cutils.h"
- #include "EST_strcasecmp.h"
- #include "siod.h"
- #include "siodp.h"
- #include "siodeditline.h"
- #ifdef EST_SIOD_ENABLE_PYTHON
- #include "slib_python.h"
- #endif
- extern "C" const char * repl_prompt;
- template <> EST_String EST_THash<EST_String, EST_Regex *>::Dummy_Key = "DUMMY";
- template <> EST_Regex *EST_THash<EST_String, EST_Regex *>::Dummy_Value = NULL;
- #if defined(INSTANTIATE_TEMPLATES)
- #include "../base_class/EST_THash.cc"
- Instantiate_TStringHash_T(EST_Regex *, hash_string_regex)
- #endif
- static EST_TStringHash<EST_Regex *> regexes(100);
- int siod_init(int heap_size)
- {
- /* Initialize siod */
- int actual_heap_size;
- if (heap_size == -1) // unspecified by user
- {
- char *char_heap_size=getenv("SIODHEAPSIZE");
- if ((char_heap_size == 0) ||
- (atoi(char_heap_size) < 1000))
- actual_heap_size=ACTUAL_DEFAULT_HEAP_SIZE;
- else
- actual_heap_size=atoi(char_heap_size);
- }
- else
- actual_heap_size = heap_size;
- init_storage(actual_heap_size);
- init_subrs();
- #ifdef EST_SIOD_ENABLE_PYTHON
- init_subrs_python();
- #endif
- return 0;
- }
- void siod_tidy_up()
- {
- #ifdef EST_SIOD_ENABLE_PYTHON
- python_tidy_up();
- #endif
- close_open_files();
- }
- LISP siod_get_lval(const char *name,const char *message)
- {
- // returns value of variable name. If not set gives an error
- LISP iii, rval=NIL;
- iii = rintern(name);
- // value or NIL if unset
- if (symbol_boundp(iii,current_env) == NIL)
- {
- if (message != NULL)
- err(message,iii);
- }
- else
- rval = symbol_value(iii, current_env);
- return rval;
- }
- LISP siod_set_lval(const char *name,LISP val)
- {
- // set variable name to val
- LISP iii, rval;
- iii = rintern(name);
- rval = setvar(iii,val,current_env);
- return rval;
- }
- LISP siod_assoc_str(const char *key,LISP alist)
- {
- // assoc without going through LISP atoms
- // made get_c_string inline for optimization
- LISP l,lc,lcc;
- for (l=alist; CONSP(l); l=CDR(l))
- {
- lc = CAR(l);
- if (CONSP(lc))
- {
- lcc = CAR(lc);
- if (NULLP(lcc)) continue;
- else if TYPEP(lcc,tc_symbol)
- {
- if (strcmp(key,PNAME(lcc))==0)
- return lc;
- }
- else if TYPEP(lcc,tc_flonum)
- {
- if (FLONMPNAME(lcc) == NULL)
- {
- char b[TKBUFFERN];
- sprintf(b,"%g",FLONM(lcc));
- FLONMPNAME(lcc) = (char *)must_malloc(strlen(b)+1);
- sprintf(FLONMPNAME(lcc),"%s",b);
- }
- if (strcmp(key,FLONMPNAME(lcc))==0)
- return lc;
- }
- else if TYPEP(lcc,tc_string)
- {
- if (strcmp(key,lcc->storage_as.string.data)==0)
- return lc;
- }
- else
- continue;
- }
- }
- return NIL;
- }
- LISP siod_member_str(const char *key,LISP list)
- {
- // member without going through LISP atoms
- LISP l;
- for (l=list; CONSP(l); l=CDR(l))
- if (strcmp(key,get_c_string(CAR(l))) == 0)
- return l;
- return NIL;
- }
- LISP siod_regex_member_str(const EST_String &key,LISP list)
- {
- // Check the regexs in LIST against key
- LISP l;
- for (l=list; CONSP(l); l=CDR(l))
- if (key.matches(make_regex(get_c_string(CAR(l)))))
- return l;
- return NIL;
- }
- LISP siod_member_int(const int key,LISP list)
- {
- // member without going through LISP atoms
- LISP l;
- for (l=list; CONSP(l); l=CDR(l))
- if (key == get_c_int(CAR(l)))
- return l;
- return NIL;
- }
- int siod_llength(LISP list)
- {
- // length of string;
- int len;
- LISP l;
- for (len=0,l=list; CONSP(l); l=CDR(l),len++);
- return len;
- }
- LISP siod_nth(int n,LISP list)
- {
- // nth member -- first member is 0;
- int i;
- LISP l;
- for (i=0,l=list; CONSP(l); l=CDR(l),i++)
- if (i == n)
- return car(l);
- return NIL;
- }
- int siod_atomic_list(LISP list)
- {
- // TRUE is list only contains atoms
- LISP p;
- for (p=list; p != NIL; p=cdr(p))
- if (CONSP(car(p)))
- return FALSE;
- return TRUE;
- }
- int siod_eof(LISP item)
- {
- // TRUE if item is what siod denotes as eof
- if (CONSP(item) &&
- (cdr(item) == NIL) &&
- (SYMBOLP(car(item))) &&
- (strcmp("eof",get_c_string(car(item))) == 0))
- return TRUE;
- else
- return FALSE;
- }
- LISP quote(LISP l)
- {
- // Add quote round a Lisp expression
- return cons(rintern("quote"),cons(l,NIL));
- }
- LISP siod_last(LISP list)
- {
- LISP l;
- if ((list == NIL) || (NCONSP(list)))
- return NIL;
- else
- {
- for (l=list; cdr(l) != NIL; l=cdr(l));
- return l;
- }
- }
- int get_param_int(const char *name, LISP params, int defval)
- {
- // Look up name in params and return value if present or
- // defval if not present
- LISP pair;
- pair = siod_assoc_str(name,params);
- if (pair == NIL)
- return defval;
- else if FLONUMP(car(cdr(pair)))
- return (int)FLONM(car(cdr(pair)));
- else
- {
- cerr << "param " << name << " not of type int" << endl;
- err("",NIL);
- return -1;
- }
- }
- float get_param_float(const char *name, LISP params, float defval)
- {
- // Look up name in params and return value if present or
- // defval if not present
- LISP pair;
- pair = siod_assoc_str(name,params);
- if (pair == NIL)
- return defval;
- else if (FLONUMP(car(cdr(pair))))
- return (float)FLONM(car(cdr(pair)));
- else
- {
- cerr << "param " << name << " not of type float" << endl;
- err("",NIL);
- return -1;
- }
- }
- const char *get_param_str(const char *name, LISP params, const char *defval)
- {
- // Look up name in params and return value if present or
- // defval if not present
- LISP pair;
- pair = siod_assoc_str(name,params);
- if (pair == NIL)
- return defval;
- else
- return get_c_string(car(cdr(pair)));
- }
- LISP get_param_lisp(const char *name, LISP params, LISP defval)
- {
- // Look up name in params and return value if present or
- // defval if not present
- LISP pair;
- pair = siod_assoc_str(name,params);
- if (pair == NIL)
- return defval;
- else
- return car(cdr(pair));
- }
- LISP make_param_str(const char *name,const char *val)
- {
- return cons(rintern(name),cons(rintern(val),NIL));
- }
- LISP make_param_int(const char *name, int val)
- {
- return cons(rintern(name),cons(flocons(val),NIL));
- }
- LISP make_param_float(const char *name, float val)
- {
- return cons(rintern(name),cons(flocons(val),NIL));
- }
- LISP make_param_lisp(const char *name,LISP val)
- {
- return cons(rintern(name),cons(val,NIL));
- }
- EST_Regex &make_regex(const char *r)
- {
- // Return pointer to existing regex if its already been created
- // otherwise create a new one for this r.
- EST_Regex *rx;
- EST_String sr = r;
- int found;
- rx = regexes.val(sr,found);
- if (!found)
- {
- rx = new EST_Regex(r);
- regexes.add_item(sr,rx);
- }
- return *rx;
- }
- LISP apply_hooks(LISP hooks,LISP arg)
- {
- // Apply each function in hooks to arg returning value from
- // final application (or arg itself)
- LISP h,r;
- r = arg;
- if (hooks && (!CONSP(hooks))) // singleton
- r = leval(cons(hooks,cons(quote(arg),NIL)),NIL);
- else
- for (h=hooks; h != NIL; h=cdr(h))
- r = leval(cons(car(h),cons(quote(arg),NIL)),NIL);
- return r;
- }
- LISP apply_hooks_right(LISP hooks,LISP args)
- {
- // The above version neither quotes its arguments properly of deals
- // with lists of arguments so here's a better one
- // Apply each function in hooks to arg returning value from
- // final application (or arg itself)
- LISP h,r;
- if (hooks == NIL)
- r = args;
- else if (!CONSP(hooks)) // singleton
- r = apply(hooks,args);
- else
- for (r=args,h=hooks; h != NIL; h=cdr(h))
- r = apply(car(h),r);
- return r;
- }
- LISP apply(LISP func,LISP args)
- {
- LISP qa,a;
- for (qa=NIL,a=args; a; a=cdr(a))
- qa = cons(quote(car(a)),qa);
- return leval(cons(func,reverse(qa)),NIL);
- }
- LISP stringexplode(const char *str)
- {
- // Explode character string into list of symbols one for each char
- LISP l=NIL;
- unsigned int i;
- char id[2];
- id[1] = '\0';
- for (i=0; i < strlen(str); i++)
- {
- id[0] = str[i];
- l = cons(rintern(id),l);
- }
- return reverse(l);
- }
- /* Editline completion functions */
- char **siod_variable_generator(char *text,int length)
- {
- LISP l,lmatches;
- const char *name;
- char **matches = NULL;
- int i;
- /* Return the next name which partially matches from the command list. */
- for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
- {
- if (VCELL(car(l)) == NIL) continue;
- switch(TYPE(VCELL(CAR(l))))
- {
- case tc_subr_0:
- case tc_subr_1:
- case tc_subr_2:
- case tc_subr_3:
- case tc_subr_4:
- case tc_lsubr:
- case tc_fsubr:
- case tc_msubr:
- case tc_closure:
- continue;
- default:
- /* only return names of nonfunctions (sometimes too restrictive) */
- name = PNAME(CAR(l));
- if (strncmp(name, text, length) == 0)
- lmatches = cons(CAR(l),lmatches);
- }
- }
- /* Need to return the matches in a char** */
- matches = walloc(char *,siod_llength(lmatches)+1);
- for (l=lmatches,i=0; l; l=cdr(l),i++)
- matches[i] = wstrdup(PNAME(car(l)));
- matches[i] = NULL;
- return matches;
- }
- char **siod_command_generator (char *text,int length)
- {
- LISP l,lmatches;
- const char *name;
- char **matches = NULL;
- int i;
- /* Return the next name which partially matches from the command list. */
- for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
- {
- if (VCELL(car(l)) == NIL) continue;
- switch(TYPE(VCELL(CAR(l))))
- {
- case tc_subr_0:
- case tc_subr_1:
- case tc_subr_2:
- case tc_subr_3:
- case tc_subr_4:
- case tc_lsubr:
- case tc_fsubr:
- case tc_msubr:
- case tc_closure:
- /* only return names of functions */
- name = PNAME(CAR(l));
- if (strncmp(name, text, length) == 0)
- lmatches = cons(CAR(l),lmatches);
- default: continue;
- }
- }
- /* Need to return the matches in a char** */
- matches = walloc(char *,siod_llength(lmatches)+1);
- for (l=lmatches,i=0; l; l=cdr(l),i++)
- matches[i] = wstrdup(PNAME(car(l)));
- matches[i] = NULL;
- return matches;
- }
- void siod_list_to_strlist(LISP l, EST_StrList &a)
- {
- // copy l into a
- LISP b;
- a.clear();
- for (b=l; b != NIL; b=cdr(b))
- a.append(get_c_string(car(b)));
- }
- LISP siod_strlist_to_list(EST_StrList &a)
- {
- // copy a into l
- LISP b=NIL;;
- EST_Litem *p;
- for (p=a.head(); p != 0; p=p->next())
- b = cons(rintern(a(p)),b);
- return reverse(b);
- }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement