home *** CD-ROM | disk | FTP | other *** search
/ M.u.C.S. Disc 2000 / MUCS2000.iso / sound / mp2_099 / src / gem / libshoe.c < prev    next >
Encoding:
Text File  |  1998-10-04  |  14.0 KB  |  176 lines
  1.    /* libshoe.c
  2.  *
  3.  * COPYRIGHT (c) 1998 by Fredrik Noring.
  4.  *
  5.  * This is the entire Shoe interpreter and runtime system.
  6.  */
  7.  
  8. #include <stdio.h>
  9. #include <stdlib.h>
  10. #include <string.h>
  11.  
  12. #include "libshoe.h"
  13.  
  14. #define BALANCE(c)       ((((c) == '(')?1:0)-(((c) == ')')?1:0))
  15. #define ERRP(x)          ((x)[0] == '#' && (x)[1] == 'E')
  16.  
  17. Byte *symbols[MAX_SYMBOLS][2];
  18. Byte *heap_pointer, *stack_pointer, *heap, errormsg[1024];
  19. Int online = 0, trace = 0, symbol_counter, bounded_counter;
  20.  
  21. void bootstrap(void);
  22. void notify(Byte *symbol, Byte *args);
  23.  
  24. Int spacep(Byte c)
  25. {
  26.   return c == '\0' || c == ' ' || c == '\t' || c == '\n' || c == '\r';
  27. }
  28.  
  29. Byte *panic(Byte *msg)
  30. {
  31.     sprintf(errormsg, "#Panic. %s", msg);
  32.     notify("panic", errormsg);
  33.     return msg;
  34. }
  35.  
  36. Byte *exterr(Byte *msg, Byte *context)
  37. {
  38.     sprintf(errormsg, "#Exception. %s%s\n", msg,
  39.             context?context:"#no-context?");
  40.     notify("error", errormsg);
  41.     return ERR;
  42. }
  43.  
  44. void check_symbol_space(void)
  45. {
  46.     if(symbol_counter >= MAX_SYMBOLS)
  47.         panic("Symbol table full.");
  48. }
  49.  
  50. Byte* call_bif(Byte *address, Byte *args)
  51. {
  52.     if(!address)
  53.         return 0;
  54.     if(address[0] != '#' || !DIGITP(address[1]))
  55.         return exterr("Cannot call: ", address);
  56. #pragma warn -pro
  57.     return (*((Byte*(*)())atol(address+1)))(args);
  58. #pragma warn .pro
  59. }
  60.  
  61. Byte* fetch_symbol(Byte *symbol)
  62. {
  63.   Int i;
  64.   
  65.   for(i = bounded_counter; i--; )
  66.     if(MATCH(symbol, symbols[i][0])) {
  67.       if(trace) printf("#-> value: [%s = %s]\n", symbol, symbols[i][1]);
  68.       return symbols[i][1];
  69.     }
  70.   return 0;
  71. }
  72.  
  73. Byte *mem(Int amount)
  74. {
  75.   if(heap_pointer+amount > stack_pointer)
  76.     panic("Out of memory.");
  77.   return (heap_pointer += amount) - amount;
  78. }
  79.  
  80. Byte *memdup(Byte *s)
  81. {
  82.   return strcpy(mem(strlen(s)+1), s);
  83. }
  84.  
  85. Byte *push_stack(Byte *s)
  86. {
  87.   return strcpy(stack_pointer -= strlen(s)+1, s);
  88. }
  89.  
  90. Byte *pop_n_elems(Int n)
  91. {
  92.     Byte *old;
  93.     
  94.     old = stack_pointer;
  95.     while(n--)
  96.         stack_pointer += strlen(stack_pointer)+1;
  97.     return old;
  98. }
  99.  
  100. void notify(Byte *symbol, Byte *args)
  101. {
  102.     call_bif(fetch_symbol(symbol), args);
  103. }
  104.  
  105. Byte *gc(void)
  106. {
  107.   Byte *chunk, *minimum;
  108.   Int s_j = 0, s_k = 0, i, j, k;
  109.  
  110.   notify("notify-gc", "#t");
  111.   minimum = heap;
  112.   for(i = 0; i < 2*symbol_counter; i++) {
  113.     chunk = heap+HEAP_SIZE;
  114.     for(j = 0; j < symbol_counter; j++)
  115.       for(k = 0; k < 2; k++)
  116.     if(symbols[j][k] <= chunk && minimum <= symbols[j][k])
  117.       chunk = symbols[s_j=j][s_k=k];
  118.     symbols[s_j][s_k] = minimum;
  119.     while(*chunk)
  120.       *minimum++ = *chunk++;
  121.     *minimum++ = '\0';
  122.   }
  123.   heap_pointer = minimum;
  124.   notify("notify-gc", "#f");
  125.   return T;
  126. }
  127.  
  128. Byte *trim(Byte *s)
  129. {
  130.   while(spacep(*s))
  131.     s++;
  132.   return s;
  133. }
  134.  
  135. Byte *suf(Byte *a, Byte *b)
  136. {
  137.   Byte *s;
  138.   
  139.   sprintf(s = mem(strlen(a)+strlen(b)+1), "%s%s", a, b);
  140.   return s;
  141. }
  142.  
  143. Int statement_size(Byte* s)
  144. {
  145.   Byte *source;
  146.   Int nbalance = 0;
  147.   
  148.   source = s = trim(s);
  149.   while(nbalance | !((spacep(*s) | (*s == ')')) || (*s == '(' && s-source))) {
  150.     nbalance += BALANCE(*s);
  151.     s++;
  152.   }
  153.   return s-source;
  154. }
  155.  
  156. Byte *car(Byte* s)
  157. {
  158.   Int size;
  159.   
  160.   if(!LISTP(s)) return exterr("Cannot car: ", s);
  161.   if(NILP(s)) return s;
  162.   size = statement_size(++s);
  163.   s = strncpy(mem(size+1), s, size);
  164.   s[size] = '\0';
  165.   return s;
  166. }
  167.  
  168. Byte *cdr(Byte *s)
  169. {
  170.   if(!LISTP(s)) return exterr("Cannot cdr: ", s);
  171.   s = trim(s+statement_size(++s));
  172.   s = strcpy(mem(strlen(s)+2)+1, s)-1;
  173.   s[0] = '(';
  174.   return s;
  175. }
  176.  
  177. Byte *bind_symbol(Byte *symbol, Byte *value)
  178. {
  179.   Int old_definition, ok = 0;
  180.  
  181.   for(old_definition = bounded_counter; old_definition--; )
  182.     if(MATCH(symbol, symbols[old_definition][0])) {
  183.         ok = 1;
  184.         break;
  185.     }
  186.  
  187.     if(!ok) {
  188.         check_symbol_space();
  189.         bounded_counter++;
  190.     }
  191.     symbols[ok?old_definition:symbol_counter][1] = value;
  192.     return symbols[ok?old_definition:symbol_counter++][0] = symbol;
  193. }
  194.  
  195. Byte *bif_cons(Byte *s)
  196. {
  197.   DUAL_EVAL(s, (NILP(b)?sprintf(s = mem(strlen(a)+3), "(%s)", a):
  198.         LISTP(b)?sprintf(s = mem(strlen(a)+strlen(b)+3), "(%s %s", a, b+1):
  199.         sprintf(s = mem(strlen(a)+strlen(b)+4), "(%s %s)", a, b)));
  200. }
  201.  
  202. Byte *bif_lambda(Byte *s)
  203. {
  204.   return suf("#lambda ", s);
  205. }
  206.  
  207. Byte *bif_macro(Byte *s)
  208. {
  209.   return suf("#macro ", s);
  210. }
  211.  
  212. Byte *bif_car(Byte *s)
  213. {
  214.   return car(EVAL(s));
  215. }
  216.  
  217. Byte *bif_cdr(Byte *s)
  218. {
  219.   return cdr(EVAL(s));
  220. }
  221.  
  222. Byte *bif_if(Byte *s)
  223. {
  224.   s = EVALARG(FP(EVAL(s = push_stack(s)))?cdr(s):s);
  225.   pop_n_elems(1);
  226.   return s;
  227. }
  228.  
  229. Byte *bif_equal(Byte *s)
  230. {
  231.   DUAL_EVAL(s, s = MATCH(a, b)?T:F);
  232. }
  233.  
  234. Byte *bif_function(Byte* s)
  235. {
  236.   return EVAL(s);
  237. }
  238.  
  239. Byte *bif_eval(Byte* s)
  240. {
  241.   return eval(EVAL(s));
  242. }
  243.  
  244. Byte *bif_trace(Byte *s)
  245. {
  246.   return ((trace=TP(EVAL(s)))!=0)?T:F;
  247. }
  248.  
  249. Byte *bif_define(Byte *s)
  250. {
  251.   return (bind_symbol(car(s), NILP(cdr(cdr(s)))?
  252.           eval(car(cdr(s))):suf("#lambda ", cdr(s))));
  253. }
  254.  
  255. Byte *bif_memory(Byte *s)
  256. {
  257.   sprintf(s = mem(64), "((heap %lu) (stack %lu) (available %lu) (total %lu))",
  258.       (unsigned long) (heap_pointer-heap),
  259.       (unsigned long) (heap+HEAP_SIZE-stack_pointer),
  260.       (unsigned long) (stack_pointer-heap_pointer),
  261.       (unsigned long) (HEAP_SIZE));
  262.   return s;
  263. }
  264.  
  265. Byte *eval(Byte *s)
  266. {
  267.   Byte macro, *args, *vars, *body;
  268.   Int rest = 0, old_symbol_counter, old_bounded_counter;
  269.  
  270.   if(!s) exit(0);
  271.   if(!online) bootstrap();
  272.   if(trace) printf("#eval: [%s]\n", s);
  273.   s = trim(s);
  274.   if(strlen(s) == 0 || s[0] == '#' || DIGITP(*s) || NILP(s))
  275.     return s;
  276.   if((body = fetch_symbol(s)) != 0)
  277.     return body;
  278.  
  279.   s = push_stack(s);
  280.   if(stack_pointer-heap_pointer < GC_MINIMUM)
  281.     gc();
  282.   body = push_stack(EVAL(s));
  283.   args = push_stack(cdr(s));
  284.   if(body[0] == '#' && (body[1] == 'l' || body[1] == 'm')) {
  285.     macro = body[1]=='m';
  286.     body += (macro?7:8);
  287.     old_symbol_counter = symbol_counter;
  288.     old_bounded_counter = bounded_counter;
  289.     vars = push_stack(car(body));
  290.     while(!ERRP(vars) && !ERRP(args) && (!NILP(args) || !NILP(vars))) {
  291.       s = memdup(macro?car(args):EVAL(args));
  292.       if(rest) {
  293.     Byte *t;
  294.     t = symbols[rest][1];
  295.     t[strlen(t)-1] = '\0';
  296.     symbols[rest][1] = suf(suf(suf(t, " "), s), ")");
  297.       } else {
  298.     if(MATCH(car(vars), "#rest")) {
  299.       s = NILP(args)?memdup("()"):suf(suf("(", s), ")");
  300.       vars = cdr(vars);
  301.       rest = symbol_counter;
  302.     }
  303.     check_symbol_space();
  304.     symbols[symbol_counter][1] = s;
  305.     symbols[symbol_counter++][0] = memdup(car(vars));
  306.       }
  307.       vars = cdr(vars);
  308.       args = cdr(args);
  309.       pop_n_elems(2);
  310.       vars = push_stack(vars);
  311.       args = push_stack(args);
  312.     }
  313.     bounded_counter = symbol_counter;
  314.     s = EVALARG(body);
  315.     pop_n_elems(4);
  316.     symbol_counter = old_symbol_counter;
  317.     bounded_counter = old_bounded_counter;
  318.     return macro?eval(s):s;
  319.   }
  320.   s = ERRP(body)?memdup(body):call_bif(body, args);
  321.   pop_n_elems(3);
  322.   return s;
  323. }
  324.  
  325. void bif(Byte *symbol, void *f)
  326. {
  327.   if(!online) bootstrap();
  328.   
  329.   bounded_counter++;
  330.   check_symbol_space();
  331.   sprintf(symbols[symbol_counter][0] = mem(strlen(symbol)+1), "%s", symbol);
  332.   sprintf(symbols[symbol_counter++][1] = mem(17), "#%lu", (unsigned long) f);
  333. }
  334.  
  335. Byte *decode_string(Byte *s)
  336. {
  337.     Byte *o, *d;
  338.  
  339.     if(!s)
  340.         return 0;
  341.     o = d = s = memdup(s);
  342.     while(*s)
  343.         if(*s == '%') {
  344.             *d++ = *++s=='_'?' ':*s;
  345.             s++;
  346.         } else
  347.             *d++ = *s++;
  348.     *d = '\0';
  349.     return o;
  350. }
  351.  
  352. static Int nbalance = 0;
  353. Int inquire_balance(void)
  354. {
  355.     return nbalance;
  356. }
  357.  
  358. #define PARSE_RESET() { state = 0; nbalance = 0; src = src_start = 0; }
  359.  
  360. Byte *parse_eval(Byte *input)
  361. {
  362.     static int state = 0;
  363.     static Byte *src_stack = 0, last = '\0';
  364.     Byte *src = 0, *src_start = 0, *result = 0, *eos;
  365.  
  366.     if(!online) bootstrap();
  367.     
  368.     if(src_stack) {
  369.         src = src_start = memdup(src_stack);
  370.         src += strlen(src);
  371.         pop_n_elems(1);
  372.         src_stack = 0;
  373.     }
  374.  
  375.     if(MATCH(input, ".")) { /* Interrupt current input. */
  376.         PARSE_RESET();
  377.         return 0;
  378.     }
  379.     
  380.     eos = input+strlen(input);
  381.     while(input <= eos) {
  382.         if(!src)
  383.             src = src_start = mem(1);
  384.     
  385.         switch(state) {
  386.         case 0:   /* Read whitespace. */
  387.             if(*input == ';')
  388.                 state = 3;
  389.             else if(*input == '{')
  390.                 state = 4;
  391.             else if(spacep(*input))
  392.                 input++;
  393.             else
  394.                 state = 1;
  395.             break;
  396.         case 1:   /* Read non whitespace characters. */
  397.             if((spacep(*input) || *input == ';' || *input == '{') &&
  398.                nbalance == 0) {
  399.                 state = 2;
  400.             } else if(*input == '"') {
  401.                 mem(7);
  402.                 *src++ = '('; *src++ = 'q'; *src++ = 'u'; *src++ = 'o';
  403.                 *src++ = 't'; *src++ = 'e'; *src++ = ' ';
  404.                 state = 5;
  405.                 input++;
  406.             } else {
  407.                 if(spacep(*input) || *input == ';' || *input == '{') {
  408.                     state = 0;
  409.                     if(last == '(')
  410.                         break;
  411.                 }
  412.                 if(*input == ')' && spacep(last))
  413.                     src--;
  414.                 nbalance += BALANCE(*input);
  415.                 last = *input;
  416.                 *src++ = spacep(*input)?' ':*input++;
  417.                 mem(1);
  418.             }
  419.             break;
  420.         case 2:   /* Evaluate. */
  421.             *src = '\0';
  422.             result = eval(src_start);
  423.             PARSE_RESET();
  424.             break;
  425.         case 3:   /* Skip ; comments. */
  426.             if(*input == '\n' || *input == '\r' || *input == '\0')
  427.                 state = 0;
  428.             input++;
  429.             break;
  430.         case 4:   /* Skip { } comments. */
  431.             if(*input == '}')
  432.                 state = 0;
  433.             input++;
  434.             break;
  435.         case 5:   /* Read string. */
  436.             if(*input == '"') {
  437.                 *src++ = ')';
  438.                 mem(1);
  439.                 state = 1;
  440.             } else {
  441.                 if(spacep(*input)) {
  442.                     *src++ = '%';
  443.                     *src++ = '_';
  444.                     mem(1);
  445.                 } else if(*input == '%') {
  446.                     *src++ = '%';
  447.                     *src++ = '%';
  448.                     mem(1);
  449.                 } else
  450.                     *src++ = *input;
  451.                 mem(1);
  452.             }
  453.             last = *input++;
  454.         }
  455.     }
  456.  
  457.     if(nbalance < 0) {
  458.         PARSE_RESET();
  459.         return "mismatched )";
  460.     }
  461.  
  462.     if(src) {
  463.         *src = '\0';
  464.         src_stack = push_stack(src_start);
  465.     }
  466.     return decode_string(result);
  467. }
  468.  
  469. /*
  470.  * Built-in functions, outside the Shoe kernel itself.
  471.  */
  472.  
  473. #define NUMERICAL(op, ix, fu)                             \
  474.   Byte* fu(Byte* args)                                    \
  475.   {                                                       \
  476.     Int x = ix;                                           \
  477.     Byte *tail, *result;                                  \
  478.                                                           \
  479.     if(!NILP(args)) {                                     \
  480.         tail = push_stack(cdr(args));                     \
  481.         x = atol(EVAL(args));                             \
  482.         op;                                               \
  483.         pop_n_elems(1);                                   \
  484.     }                                                     \
  485.     return sprintf(result = mem(16), "%ld", x), result;   \
  486.   }
  487.  
  488. NUMERICAL(x = x + atol(bif_plus(tail)),                  0, bif_plus);
  489. NUMERICAL(x = NILP(tail)?-x:x - atol(bif_plus(tail)),    0, bif_minus);
  490. NUMERICAL(x = x * atol(bif_multiply(tail)),              1, bif_multiply);
  491. NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)
  492.             return memdup("#DIV."); x = x / tx; },       1, bif_divide);
  493. NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)
  494.             return memdup("#MOD."); x = x % tx; },       0, bif_modulo);
  495.  
  496. Int numberp(Byte *s)
  497. {
  498.     while(*s)
  499.         if(DIGITP(*s))
  500.             s++;
  501.         else
  502.             return 0;
  503.     return 1;
  504. }
  505.  
  506. Byte *bif_numberp(Byte* s)
  507. {
  508.   return numberp(EVAL(s))?T:F;
  509. }
  510.  
  511. Byte *bif_listp(Byte* s)
  512. {
  513.   return LISTP(EVAL(s))?T:F;
  514. }
  515.  
  516. Int less_thanp(Byte *a, Byte *b)
  517. {
  518.   return numberp(a)&&numberp(b)?atol(a)<atol(b):strcmp(a,b)<0;
  519. }
  520.  
  521. Byte *bif_less_than(Byte *s)
  522. {
  523.   DUAL_EVAL(s, s=less_thanp(a,b)?T:F);
  524. }
  525.  
  526. Byte *bif_symbol_to_string(Byte *args)
  527. {
  528.     Byte *result, buf[4];
  529.     
  530.     if(NILP(args))
  531.         return memdup("()");
  532.     args = decode_string(EVAL(args));
  533.     result = mem(2);
  534.     result[0] = '(';
  535.     result[1] = '\0';
  536.     while(*args) {
  537.         sprintf(buf, "%d ", (int) *args++);
  538.         mem(strlen(buf));
  539.         strcat(result, buf);
  540.     }
  541.     result[strlen(result)-1] = ')';
  542.     return result;
  543. }
  544.  
  545. /*
  546.  * Optimizations. These functions are already easily expressable in Shoe.
  547.  * However, they are too damn slow too. Therefore their equivalents are
  548.  * available here, written in C.
  549.  */
  550.  
  551. Byte *bif_sort(Byte *args)
  552. {
  553.     Int length, nargs, i, j;
  554.     Byte *result, *s, *r, *selected, *current;
  555.  
  556.     args = EVAL(args);
  557.     length = strlen(args);
  558.     args[length-1] = '\0';
  559.     args++;
  560.     result = mem(length+1);
  561.     
  562.     nargs = NILP(args)?0:1;
  563.     for(s = args; *s; s++)
  564.         if(*s == ' ') {
  565.             *s = '\0';
  566.             nargs++;
  567.         }
  568.  
  569.     r = result;
  570.     *r++ = '(';
  571.     for(i = 0; i < nargs; i++) {
  572.         selected = current = args;
  573.         for(j = 0; j < nargs; j++) {
  574.             if((*selected == ' ' || less_thanp(current, selected)) &&
  575.                 *current != ' ')
  576.                 selected = current;
  577.             current += strlen(current)+1;
  578.         }
  579.         s = selected;
  580.         while(*s)
  581.             *r++ = *s++;
  582.         *selected = ' ';
  583.         if(i != nargs-1)
  584.             *r++ = ' ';
  585.     }
  586.     *r++ = ')';
  587.     *r++ = '\0';
  588.     return result;
  589. }
  590.  
  591. Byte *bif_append(Byte *args)
  592. {
  593.     Byte *arg, *result;
  594.     Int nargs = 0, length, total_length = 0;
  595.  
  596.     args = push_stack(args);
  597.     while(LISTP(args) && !NILP(args)) {
  598.         arg = EVAL(args);
  599.         args = cdr(args);
  600.         pop_n_elems(1);
  601.         if(!NILP(arg)) {
  602.             push_stack(arg);
  603.             length = strlen(arg);
  604.             total_length += length;
  605.             nargs++;
  606.         }
  607.         args = push_stack(args);
  608.     }
  609.     pop_n_elems(1);
  610.     
  611.     result = mem(total_length+3)+total_length;
  612.     *result-- = '\0';
  613.     *result = ')';
  614.     while(nargs--) {
  615.         arg = pop_n_elems(1);
  616.         length = strlen(arg)-2;
  617.         result -= length;
  618.         strncpy(result, arg+1, length);
  619.         if(nargs > 0)
  620.             *--result = ' ';
  621.     }
  622.     *--result = '(';
  623.     return result;
  624. }
  625.  
  626. /*
  627.  * Bootstrap for initializing the Shoe kernel.
  628.  */
  629.  
  630. void bootstrap(void)
  631. {
  632.   heap = malloc(HEAP_SIZE);
  633.   if(!heap) {
  634.     fprintf(stderr, "No memory for heap!\n");
  635.     exit(1);
  636.   }
  637.  
  638.   online = 1;
  639.   heap_pointer = heap;
  640.   stack_pointer = heap+HEAP_SIZE;
  641.   symbol_counter = bounded_counter = 0;
  642.   
  643.   /* Kernel functions. */
  644.   bif("eval",     bif_eval);
  645.   bif("function", bif_function);
  646.   bif("quote",    car);
  647.   bif("lambda",   bif_lambda);
  648.   bif("macro",    bif_macro);
  649.   bif("define",   bif_define);
  650.   bif("if",       bif_if);
  651.   bif("equal",    bif_equal);
  652.   bif("car",      bif_car);
  653.   bif("cdr",      bif_cdr);
  654.   bif("cons",     bif_cons);
  655.   bif("memory",   bif_memory);
  656.   bif("trace",    bif_trace);
  657.   bif("gc",       gc);
  658.  
  659.   /* General functions. */
  660.   bif("<",        bif_less_than);
  661.   
  662.   /* Numerical functions. */
  663.   bif("+",        bif_plus);
  664.   bif("-",        bif_minus);
  665.   bif("*",        bif_multiply);
  666.   bif("/",        bif_divide);
  667.   bif("%",        bif_modulo);
  668.   
  669.   /* Predicates. */
  670.   bif("number?",  bif_numberp);
  671.   bif("list?",    bif_listp);
  672.   
  673.   /* Optimizations. */
  674.   bif("append",    bif_append);
  675.   bif("sort",      bif_sort);
  676.   
  677.   /* Strings. */
  678.   bif("symbol-to-string", bif_symbol_to_string);
  679. }
  680.