API tools faq
paste
Guest User

Untitled

a guest
Apr 27th, 2017
581
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
C 11.61 KB | None | 0 0
raw download clone embed print report
  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. [email protected] or [email protected] or [email protected]
  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 ([email protected]) 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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.      
  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.  
  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.  
  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.  
  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.  
  250. LISP quote(LISP l)
  251. {
  252.     // Add quote round a Lisp expression
  253.     return cons(rintern("quote"),cons(l,NIL));
  254. }
  255.  
  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.  
  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.  
  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.  
  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.  
  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.  
  339. LISP make_param_str(const char *name,const char *val)
  340. {
  341.     return cons(rintern(name),cons(rintern(val),NIL));
  342. }
  343.  
  344. LISP make_param_int(const char *name, int val)
  345. {
  346.     return cons(rintern(name),cons(flocons(val),NIL));
  347. }
  348.  
  349. LISP make_param_float(const char *name, float val)
  350. {
  351.     return cons(rintern(name),cons(flocons(val),NIL));
  352. }
  353.  
  354. LISP make_param_lisp(const char *name,LISP val)
  355. {
  356.     return cons(rintern(name),cons(val,NIL));
  357. }
  358.  
  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.  
  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.  
  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.  
  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.  
  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.    
  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.  
  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.  
  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.  
  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. }
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!