home *** CD-ROM | disk | FTP | other *** search
/ Fujiology Archive / fujiology_archive_v1_0.iso / !FALCON / NOCREW / MP2_0997.ZIP / mp2_0997 / src / libshoe.c < prev    next >
Text File  |  1998-11-08  |  15KB  |  216 lines
  1. /* libshoe.c * * COPYRIGHT (c) 1998 by Fredrik Noring. * * This is the entire Shoe interpreter and runtime system. */#include <stdio.h>#include <stdlib.h>#include <string.h>#include "libshoe.h"#define BALANCE(c)       ((((c) == '(')?1:0)-(((c) == ')')?1:0))#define ERRP(x)          ((x)[0] == '#' && (x)[1] == 'E')Byte *symbols[MAX_SYMBOLS][2];Byte *heap_pointer, *stack_pointer, *heap, errormsg[1024];Int online = 0, trace = 0, symbol_counter, bounded_counter;void bootstrap(void);void notify(Byte *symbol, Byte *args);Int spacep(Byte c){    return c == '\0' || c == ' ' || c == '\t' || c == '\n' || c == '\r';}Byte *panic(Byte *msg){
  2.     sprintf(errormsg, "#Panic. %s", msg);    notify("panic", errormsg);    return msg;}Byte *exterr(Byte *msg, Byte *context){    sprintf(errormsg, "#Exception. %s%s\n", msg,            context?context:"#no-context?");    notify("error", errormsg);    return ERR;}void check_symbol_space(void){    if(symbol_counter >= MAX_SYMBOLS)        panic("Symbol table full.");}Byte* call_bif(Byte *address, Byte *args){    if(!address)        return 0;    if(address[0] != '#' || !DIGITP(address[1]))        return exterr("Cannot call: ", address);#pragma warn -pro    return (*((Byte*(*)())atol(address+1)))(args);#pragma warn .pro}Byte* fetch_symbol(Byte *symbol){    Int i;      for(i = bounded_counter; i--; )        if(MATCH(symbol, symbols[i][0])) {            if(trace)
  3.                 printf("#-> value: [%s = %s]\n", symbol, symbols[i][1]);            return symbols[i][1];        }    return 0;}Byte *mem(Int amount){    if(heap_pointer+amount > stack_pointer)        panic("Out of memory.");    return (heap_pointer += amount) - amount;}Byte *memdup(Byte *s){    return strcpy(mem(strlen(s)+1), s);}Byte *push_stack(Byte *s){    return strcpy(stack_pointer -= strlen(s)+1, s);}Byte *pop_n_elems(Int n){
  4.     Byte *old;
  5.     
  6.     old = stack_pointer;    while(n--)        stack_pointer += strlen(stack_pointer)+1;
  7.     return old;}void notify(Byte *symbol, Byte *args){    call_bif(fetch_symbol(symbol), args);}Byte *gc(void){    Byte *chunk, *minimum;    Int s_j = 0, s_k = 0, i, j, k;    notify("notify-gc", "#t");    minimum = heap;    for(i = 0; i < 2*symbol_counter; i++) {        chunk = heap+HEAP_SIZE;        for(j = 0; j < symbol_counter; j++)            for(k = 0; k < 2; k++)
  8.         if(symbols[j][k] <= chunk && minimum <= symbols[j][k])
  9.             chunk = symbols[s_j=j][s_k=k];        symbols[s_j][s_k] = minimum;        while(*chunk)            *minimum++ = *chunk++;        *minimum++ = '\0';    }    heap_pointer = minimum;    notify("notify-gc", "#f");    return T;}Byte *trim(Byte *s){    while(spacep(*s))        s++;    return s;}Byte *suf(Byte *a, Byte *b){    Byte *s;      sprintf(s = mem(strlen(a)+strlen(b)+1), "%s%s", a, b);    return s;}Int statement_size(Byte* s){    Byte *source;    Int nbalance = 0;      source = s = trim(s);    while(nbalance | 
  10.             !((spacep(*s) | (*s == ')')) || (*s == '(' && s-source))) {        nbalance += BALANCE(*s);        s++;    }    return s-source;}Byte *car(Byte* s){    Int size;      if(!LISTP(s)) return exterr("Cannot car: ", s);    if(NILP(s)) return s;    size = statement_size(++s);    s = strncpy(mem(size+1), s, size);    s[size] = '\0';    return s;}Byte *cdr(Byte *s){    if(!LISTP(s)) return exterr("Cannot cdr: ", s);    s = trim(s+statement_size(++s));    s = strcpy(mem(strlen(s)+2)+1, s)-1;    s[0] = '(';    return s;}Byte *bind_symbol(Byte *symbol, Byte *value){    Int old_definition, ok = 0;
  11.     for(old_definition = bounded_counter; old_definition--; )        if(MATCH(symbol, symbols[old_definition][0])) {
  12.             ok = 1;
  13.             break;
  14.         }
  15.  
  16.     if(!ok) {
  17.         check_symbol_space();        bounded_counter++;
  18.     }    symbols[ok?old_definition:symbol_counter][1] = value;    return symbols[ok?old_definition:symbol_counter++][0] = symbol;}Byte *bif_cons(Byte *s){    DUAL_EVAL(s, (NILP(b)?sprintf(s = mem(strlen(a)+3), "(%s)", a):
  19.         LISTP(b)?sprintf(s = mem(strlen(a)+strlen(b)+3), "(%s %s", a, b+1):        sprintf(s = mem(strlen(a)+strlen(b)+4), "(%s %s)", a, b)));}Byte *bif_lambda(Byte *s){    return suf("#lambda ", s);}Byte *bif_macro(Byte *s){    return suf("#macro ", s);}Byte *bif_car(Byte *s){    return car(EVAL(s));}Byte *bif_cdr(Byte *s){    return cdr(EVAL(s));}Byte *bif_if(Byte *s){    s = EVALARG(FP(EVAL(s = push_stack(s)))?cdr(s):s);    pop_n_elems(1);    return s;}Byte *bif_equal(Byte *s){    DUAL_EVAL(s, s = MATCH(a, b)?T:F);
  20. }Byte *bif_function(Byte* s){    return EVAL(s);}Byte *bif_eval(Byte* s){    return eval(EVAL(s));}Byte *bif_trace(Byte *s){    return ((trace=TP(EVAL(s)))!=0)?T:F;}Byte *bif_define(Byte *s){    return (bind_symbol(car(s), NILP(cdr(cdr(s)))?                eval(car(cdr(s))):suf("#lambda ", cdr(s))));}Byte *bif_memory(Byte *s){    sprintf(s = mem(128), "((heap %lu) (stack %lu) (available %lu) (total %lu))",
  21.         (unsigned long) (heap_pointer-heap),        (unsigned long) (heap+HEAP_SIZE-stack_pointer),        (unsigned long) (stack_pointer-heap_pointer),        (unsigned long) (HEAP_SIZE));    return s;}Byte *eval(Byte *s){    Byte macro, *args, *vars, *body;    Int rest = 0, old_symbol_counter, old_bounded_counter;    if(!s) exit(0);    if(!online) bootstrap();    if(trace) printf("#eval: [%s]\n", s);    s = trim(s);    if(strlen(s) == 0 || s[0] == '#' || DIGITP(*s) || NILP(s))        return s;    if((body = fetch_symbol(s)) != 0)        return body;
  22.     s = push_stack(s);    if(stack_pointer-heap_pointer < GC_MINIMUM)        gc();    body = push_stack(EVAL(s));    args = push_stack(cdr(s));    if(body[0] == '#' && (body[1] == 'l' || body[1] == 'm')) {        macro = body[1]=='m';        body += (macro?7:8);        old_symbol_counter = symbol_counter;        old_bounded_counter = bounded_counter;        vars = push_stack(car(body));        while(!ERRP(vars) && !ERRP(args) && 
  23.                 (!NILP(args) || !NILP(vars))) {            s = memdup(macro?car(args):EVAL(args));            if(rest) {
  24.                 Byte *t;                t = symbols[rest][1];
  25.                 t[strlen(t)-1] = '\0';                symbols[rest][1] = suf(suf(suf(t, " "), s), ")");            } else {                if(MATCH(car(vars), "#rest")) {                    s = NILP(args)?memdup("()"):suf(suf("(", s), ")");                    vars = cdr(vars);                    rest = symbol_counter;                }                check_symbol_space();                symbols[symbol_counter][1] = s;                symbols[symbol_counter++][0] = memdup(car(vars));            }            vars = cdr(vars);            args = cdr(args);            pop_n_elems(2);            vars = push_stack(vars);            args = push_stack(args);        }        bounded_counter = symbol_counter;        s = EVALARG(body);        pop_n_elems(4);        symbol_counter = old_symbol_counter;        bounded_counter = old_bounded_counter;        return macro?eval(s):s;    }    s = ERRP(body)?memdup(body):call_bif(body, args);    pop_n_elems(3);    return s;}void bif(Byte *symbol, void *f){    if(!online) bootstrap();      bounded_counter++;    check_symbol_space();    sprintf(symbols[symbol_counter][0] = mem(strlen(symbol)+1), "%s", symbol);    sprintf(symbols[symbol_counter++][1] = mem(17), "#%lu", (unsigned long) f);}
  26. Byte *decode_string(Byte *s)
  27. {
  28.     Byte *o, *d;
  29.  
  30.     if(!s)
  31.         return 0;
  32.     o = d = s = memdup(s);
  33.     while(*s)
  34.         if(*s == '%') {
  35.             switch(*++s) {
  36.                 case '_':
  37.                     *d++ = ' ';
  38.                     break;
  39.                 case '[':
  40.                     *d++ = '(';
  41.                     break;
  42.                 case ']':
  43.                     *d++ = ')';
  44.                     break;
  45.                 default:
  46.                     *d++ = *s;
  47.                     break;
  48.             }
  49.             s++;
  50.         } else
  51.             *d++ = *s++;
  52.     *d = '\0';
  53.     return o;
  54. }
  55.  
  56. Byte *bif_string(Byte *s)
  57. {
  58.     return decode_string(car(s));
  59. }
  60. static Int nbalance = 0;Int inquire_balance(void){    return nbalance;}
  61.  
  62. #define PARSE_RESET() { state = 0; nbalance = 0; src = src_start = 0; }
  63.  
  64. Byte *parse_eval(Byte *input){    static int state = 0;    static Byte *src_stack = 0, last = '\0';
  65.     Byte *src = 0, *src_start = 0, *result = 0, *eos;    if(!online) bootstrap();        if(src_stack) {
  66.         src = src_start = memdup(src_stack);
  67.         src += strlen(src);
  68.         pop_n_elems(1);
  69.         src_stack = 0;
  70.     }
  71.  
  72.     if(MATCH(input, ".")) { /* Interrupt current input. */
  73.         PARSE_RESET();        return 0;    }        eos = input+strlen(input);    while(input <= eos) {
  74.         if(!src)
  75.             src = src_start = mem(1);
  76.             switch(state) {        case 0:   /* Read whitespace. */            if(*input == ';')                state = 3;            else if(*input == '{')                state = 4;            else if(spacep(*input))                input++;            else                state = 1;            break;        case 1:   /* Read non whitespace characters. */            if((spacep(*input) || *input == ';' || *input == '{') &&               nbalance == 0) {                state = 2;            } else if(*input == '"') {/*
  77.                 mem(7);                *src++ = '('; *src++ = 'q'; *src++ = 'u'; *src++ = 'o';                *src++ = 't'; *src++ = 'e'; *src++ = ' ';*/
  78.                 mem(8);                *src++ = '('; *src++ = 's'; *src++ = 't'; *src++ = 'r';
  79.                 *src++ = 'i'; *src++ = 'n'; *src++ = 'g'; *src++ = ' ';
  80.                 state = 5;                input++;            } else {                if(spacep(*input) || *input == ';' || *input == '{') {                    state = 0;                    if(last == '(')                        break;                }                if(*input == ')' && spacep(last))                    src--;                nbalance += BALANCE(*input);                last = *input;                *src++ = spacep(*input)?' ':*input++;                mem(1);            }            break;        case 2:   /* Evaluate. */            *src = '\0';            result = eval(src_start);
  81.             PARSE_RESET();
  82.             break;        case 3:   /* Skip ; comments. */            if(*input == '\n' || *input == '\r' || *input == '\0')                state = 0;            input++;            break;        case 4:   /* Skip { } comments. */            if(*input == '}')                state = 0;            input++;            break;        case 5:   /* Read string. */            if(*input == '"') {                *src++ = ')';                mem(1);                state = 1;            } else {
  83.                 if(spacep(*input)) {
  84.                     *src++ = '%';                    *src++ = '_';                    mem(1);                } else if(*input == '%') {
  85.                     *src++ = '%';                    *src++ = '%';                    mem(1);                } else if(*input == '(') {
  86.                     *src++ = '%';                    *src++ = '[';                    mem(1);                } else if(*input == ')') {
  87.                     *src++ = '%';                    *src++ = ']';                    mem(1);                } else                    *src++ = *input;                mem(1);            }            last = *input++;
  88.         }    }
  89.     if(nbalance < 0) {        PARSE_RESET();        return "mismatched )";    }
  90.     if(src) {
  91.         *src = '\0';
  92.         src_stack = push_stack(src_start);
  93.     }
  94.     return result;
  95. /*    return decode_string(result); */}/* * Built-in functions, outside the Shoe kernel itself. */#define NUMERICAL(op, ix, fu)                           \    Byte* fu(Byte* args)                                 \    {                                                    \
  96.     Int x = ix;                                          \    Byte *tail, *result;                                 \                                                         \    if(!NILP(args)) {                                    \        tail = push_stack(cdr(args));                     \            x = atol(EVAL(args));                          \        op;                                               \        pop_n_elems(1);                                   \    }                                                    \    return sprintf(result = mem(16), "%ld", x), result;  \    }NUMERICAL(x = x + atol(bif_plus(tail)),                  0, bif_plus);NUMERICAL(x = NILP(tail)?-x:x - atol(bif_plus(tail)),    0, bif_minus);NUMERICAL(x = x * atol(bif_multiply(tail)),              1, bif_multiply);NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)            return memdup("#DIV."); x = x / tx; },       1, bif_divide);NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)            return memdup("#MOD."); x = x % tx; },       0, bif_modulo);
  97. Int numberp(Byte *s)
  98. {
  99.     while(*s)
  100.         if(DIGITP(*s))
  101.             s++;
  102.         else
  103.             return 0;
  104.     return 1;
  105. }
  106. Byte *bif_numberp(Byte* s){    return numberp(EVAL(s))?T:F;}Byte *bif_listp(Byte* s){    return LISTP(EVAL(s))?T:F;}Int less_thanp(Byte *a, Byte *b){
  107.     return numberp(a)&&numberp(b)?atol(a)<atol(b):strcmp(a,b)<0;}
  108. Byte *bif_less_than(Byte *s){
  109.     DUAL_EVAL(s, s=less_thanp(a,b)?T:F);}
  110. Byte *bif_symbol_to_string(Byte *args)
  111. {
  112.     Byte *result, buf[4];
  113.     
  114.     if(NILP(args))
  115.         return memdup("()");
  116.     args = decode_string(EVAL(args));
  117.     result = mem(2);
  118.     result[0] = '(';
  119.     result[1] = '\0';
  120.     while(*args) {
  121.         sprintf(buf, "%d ", (int) *args++);
  122.         mem(strlen(buf));
  123.         strcat(result, buf);
  124.     }
  125.     result[strlen(result)-1] = ')';
  126.     return result;
  127. }
  128.  
  129. /*
  130.  * Optimizations. These functions are already easily expressable in Shoe.
  131.  * However, they are too damn slow too. Therefore their equivalents are
  132.  * available here, written in C.
  133.  */
  134.  
  135. Byte *bif_sort(Byte *args){
  136.     Int length, nargs, i, j;
  137.     Byte *result, *s, *r, *selected, *current;
  138.  
  139.     args = EVAL(args);
  140.     length = strlen(args);
  141.     args[length-1] = '\0';
  142.     args++;
  143.     result = mem(length+1);
  144.     
  145.     nargs = NILP(args)?0:1;
  146.     for(s = args; *s; s++)
  147.         if(*s == ' ') {
  148.             *s = '\0';
  149.             nargs++;
  150.         }
  151.  
  152.     r = result;
  153.     *r++ = '(';
  154.     for(i = 0; i < nargs; i++) {
  155.         selected = current = args;
  156.         for(j = 0; j < nargs; j++) {
  157.             if((*selected == ' ' || less_thanp(current, selected)) &&
  158.                 *current != ' ')
  159.                 selected = current;
  160.             current += strlen(current)+1;
  161.         }
  162.         s = selected;
  163.         while(*s)
  164.             *r++ = *s++;
  165.         *selected = ' ';
  166.         if(i != nargs-1)
  167.             *r++ = ' ';
  168.     }
  169.     *r++ = ')';
  170.     *r++ = '\0';
  171.     return result;
  172. }
  173.  
  174. Byte *bif_append(Byte *args){
  175.     Byte *arg, *result;
  176.     Int nargs = 0, length, total_length = 0;
  177.  
  178.     args = push_stack(args);
  179.     while(LISTP(args) && !NILP(args)) {
  180.         arg = EVAL(args);
  181.         args = cdr(args);
  182.         pop_n_elems(1);
  183.         if(!NILP(arg)) {
  184.             push_stack(arg);
  185.             length = strlen(arg);
  186.             total_length += length;
  187.             nargs++;
  188.         }
  189.         args = push_stack(args);
  190.     }
  191.     pop_n_elems(1);
  192.     
  193.     result = mem(total_length+3)+total_length;
  194.     *result-- = '\0';
  195.     *result = ')';
  196.     while(nargs--) {
  197.         arg = pop_n_elems(1);
  198.         length = strlen(arg)-2;
  199.         result -= length;
  200.         strncpy(result, arg+1, length);
  201.         if(nargs > 0)
  202.             *--result = ' ';
  203.     }
  204.     *--result = '(';
  205.     return result;
  206. }
  207. /* * Bootstrap for initializing the Shoe kernel. */void bootstrap(void){    heap = malloc(HEAP_SIZE);    if(!heap) {        fprintf(stderr, "No memory for heap!\n");        exit(1);    }    online = 1;    heap_pointer = heap;    stack_pointer = heap+HEAP_SIZE;    symbol_counter = bounded_counter = 0;      /* Kernel functions. */    bif("eval",     bif_eval);    bif("function", bif_function);    bif("quote",    car);
  208.     bif("string",   bif_string);
  209.     bif("lambda",   bif_lambda);    bif("macro",    bif_macro);    bif("define",   bif_define);    bif("if",       bif_if);    bif("equal",    bif_equal);    bif("car",      bif_car);    bif("cdr",      bif_cdr);    bif("cons",     bif_cons);    bif("memory",   bif_memory);    bif("trace",    bif_trace);    bif("gc",       gc);        /* General functions. */    bif("<",        bif_less_than);         /* Numerical functions. */    bif("+",        bif_plus);    bif("-",        bif_minus);    bif("*",        bif_multiply);    bif("/",        bif_divide);    bif("%",        bif_modulo);          /* Predicates. */    bif("number?",  bif_numberp);    bif("list?",    bif_listp);
  210.      
  211.     /* Optimizations. */    bif("append",    bif_append);
  212.     bif("sort",      bif_sort);
  213.       
  214.     /* Strings. */
  215.     bif("symbol-to-string", bif_symbol_to_string);
  216. }