cvs/stack/stack.c

/* -*- coding: utf-8; -*- */
/*
    stack - an interactive interpreter for a stack-based language
    Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

    Authors: Mats Alritzson <masse@fukt.bth.se>
             Teddy Hogeborn <teddy@fukt.bth.se>
*/

#include "stack.h"

const char* start_message= "Stack version $Revision: 1.131 $\n\
Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
This is free software, and you are welcome to redistribute it\n\
under certain conditions; type 'copying;' for details.\n";


/* Initialize a newly created environment */
void init_env(environment *env)
{
  int i;

  env->gc_limit= 400000;
  env->gc_count= 0;
  env->gc_ref= NULL;

  env->head= new_val(env);
  for(i= 0; i<HASHTBLSIZE; i++)
    env->symbols[i]= NULL;
  env->err= 0;
  env->in_string= NULL;
  env->free_string= NULL;
  env->inputstream= stdin;
  env->interactive= 1;
}


void printerr(const char* in_string)
{
  fprintf(stderr, "Err: %s\n", in_string);
}


/* Returns a pointer to a pointer to an element in the hash table. */
symbol **hash(hashtbl in_hashtbl, const char *in_string)
{
  int i= 0;
  unsigned int out_hash= 0;
  char key= '\0';
  symbol **position;
  
  while(1){                     /* Hash in_string */
    key= in_string[i++];
    if(key=='\0')
      break;
    out_hash= out_hash*32+key;
  }

  out_hash= out_hash%HASHTBLSIZE;
  position= &(in_hashtbl[out_hash]);

  while(1){
    if(*position==NULL)         /* If empty */
      return position;
    
    if(strcmp(in_string, (*position)->id)==0) /* If match */
      return position;

    position= &((*position)->next); /* Try next */
  }
}


/* Create new value */
value* new_val(environment *env)
{
  value *nval= malloc(sizeof(value));
  stackitem *nitem= malloc(sizeof(stackitem));

  assert(nval != NULL);
  assert(nitem != NULL);

  nval->content.ptr= NULL;
  nval->type= empty;

  nitem->item= nval;
  nitem->next= env->gc_ref;

  env->gc_ref= nitem;

  env->gc_count += sizeof(value);
  nval->gc.flag.mark= 0;
  nval->gc.flag.protect= 0;

  return nval;
}


/* Mark values recursively. 
   Marked values are not collected by the GC. */
inline void gc_mark(value *val)
{
  if(val==NULL || val->gc.flag.mark)
    return;

  val->gc.flag.mark= 1;

  if(val->type==tcons) {
    gc_mark(CAR(val));
    gc_mark(CDR(val));
  }
}


/* Start GC */
extern void gc_init(environment *env)
{
  stackitem *new_head= NULL, *titem;
  symbol *tsymb;
  int i;

  if(env->interactive)
    printf("Garbage collecting.");

  /* Mark values on stack */
  gc_mark(env->head);

  if(env->interactive)
    printf(".");

  /* Mark values in hashtable */
  for(i= 0; i<HASHTBLSIZE; i++)
    for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
      if (tsymb->val != NULL)
        gc_mark(tsymb->val);

  if(env->interactive)
    printf(".");

  env->gc_count= 0;

  while(env->gc_ref!=NULL) {    /* Sweep unused values */
    if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */

      /* Remove content */
      switch(env->gc_ref->item->type){
      case string:
        free(env->gc_ref->item->content.string);
        break;
      case tcons:
        free(env->gc_ref->item->content.c);
        break;
      case port:
      case empty:
      case integer:
      case tfloat:
      case func:
      case symb:
        /* Symbol strings are freed when walking the hash table */
        break;
      }

      free(env->gc_ref->item);  /* Remove from gc_ref */
      titem= env->gc_ref->next;
      free(env->gc_ref);        /* Remove value */
      env->gc_ref= titem;
      continue;
    }

#ifdef DEBUG
    printf("Kept value (%p)", env->gc_ref->item);
    if(env->gc_ref->item->gc.flag.mark)
      printf(" (marked)");
    if(env->gc_ref->item->gc.flag.protect)
      printf(" (protected)");
    switch(env->gc_ref->item->type){
    case integer:
      printf(" integer: %d", env->gc_ref->item->content.i);
      break;
    case func:
      printf(" func: %p", env->gc_ref->item->content.func);
      break;
    case symb:
      printf(" symb: %s", env->gc_ref->item->content.sym->id);
      break;
    case tcons:
      printf(" tcons: %p\t%p", CAR(env->gc_ref->item),
             CDR(env->gc_ref->item));
      break;
    default:
      printf(" <unknown %d>", (env->gc_ref->item->type));
    }
    printf("\n");
#endif /* DEBUG */

    /* Keep values */     
    env->gc_count += sizeof(value);
    if(env->gc_ref->item->type==string)
      env->gc_count += strlen(env->gc_ref->item->content.string)+1;
    
    titem= env->gc_ref->next;
    env->gc_ref->next= new_head;
    new_head= env->gc_ref;
    new_head->item->gc.flag.mark= 0;
    env->gc_ref= titem;
  }

  if (env->gc_limit < env->gc_count*2)
    env->gc_limit= env->gc_count*2;

  env->gc_ref= new_head;

  if(env->interactive)
    printf("done (%d bytes still allocated)\n", env->gc_count);

}


inline void gc_maybe(environment *env)
{
  if(env->gc_count < env->gc_limit)
    return;
  else
    return gc_init(env);
}


/* Protect values from GC */
void protect(value *val)
{
  if(val==NULL || val->gc.flag.protect)
    return;

  val->gc.flag.protect= 1;

  if(val->type==tcons) {
    protect(CAR(val));
    protect(CDR(val));
  }
}


/* Unprotect values from GC */
void unprotect(value *val)
{
  if(val==NULL || !(val->gc.flag.protect))
    return;

  val->gc.flag.protect= 0;

  if(val->type==tcons) {
    unprotect(CAR(val));
    unprotect(CDR(val));
  }
}


/* Push a value onto the stack */
void push_val(environment *env, value *val)
{
  value *new_value= new_val(env);

  new_value->content.c= malloc(sizeof(pair));
  assert(new_value->content.c!=NULL);
  env->gc_count += sizeof(pair);
  new_value->type= tcons;
  CAR(new_value)= val;
  CDR(new_value)= env->head;
  env->head= new_value;
}


/* Push an integer onto the stack */
void push_int(environment *env, int in_val) 
{
  value *new_value= new_val(env);
  
  new_value->content.i= in_val;
  new_value->type= integer;

  push_val(env, new_value);
}


/* Push a floating point number onto the stack */
void push_float(environment *env, float in_val)
{
  value *new_value= new_val(env);

  new_value->content.f= in_val;
  new_value->type= tfloat;

  push_val(env, new_value);
}


/* Copy a string onto the stack. */
void push_cstring(environment *env, const char *in_string)
{
  value *new_value= new_val(env);
  int length= strlen(in_string)+1;

  new_value->content.string= malloc(length);
  assert(new_value != NULL);
  env->gc_count += length;
  strcpy(new_value->content.string, in_string);
  new_value->type= string;

  push_val(env, new_value);
}


/* Mangle a symbol name to a valid C identifier name */
char *mangle_str(const char *old_string)
{
  char validchars[]= "0123456789abcdef";
  char *new_string, *current;

  new_string= malloc((strlen(old_string)*2)+4);
  assert(new_string != NULL);
  strcpy(new_string, "sx_");    /* Stack eXternal */
  current= new_string+3;

  while(old_string[0] != '\0'){
    current[0]= validchars[(unsigned char)(old_string[0])/16];
    current[1]= validchars[(unsigned char)(old_string[0])%16];
    current+= 2;
    old_string++;
  }
  current[0]= '\0';

  return new_string;            /* The caller must free() it */
}


/* Push a symbol onto the stack. */
void push_sym(environment *env, const char *in_string)
{
  value *new_value;             /* A new symbol value */
  /* ...which might point to... */
  symbol **new_symbol;          /* (if needed) A new actual symbol */
  /* ...which, if possible, will be bound to... */
  value *new_fvalue;            /* (if needed) A new function value */
  /* ...which will point to... */
  void *funcptr;                /* A function pointer */

  static void *handle= NULL;    /* Dynamic linker handle */
  const char *dlerr;            /* Dynamic linker error */
  char *mangled;                /* Mangled function name */

  new_value= new_val(env);
  protect(new_value);
  new_fvalue= new_val(env);
  protect(new_fvalue);

  /* The new value is a symbol */
  new_value->type= symb;

  /* Look up the symbol name in the hash table */
  new_symbol= hash(env->symbols, in_string);
  new_value->content.sym= *new_symbol;

  if(*new_symbol==NULL) { /* If symbol was undefined */

    /* Create a new symbol */
    (*new_symbol)= malloc(sizeof(symbol));
    assert((*new_symbol) != NULL);
    (*new_symbol)->val= NULL;   /* undefined value */
    (*new_symbol)->next= NULL;
    (*new_symbol)->id= malloc(strlen(in_string)+1);
    assert((*new_symbol)->id != NULL);
    strcpy((*new_symbol)->id, in_string);

    /* Intern the new symbol in the hash table */
    new_value->content.sym= *new_symbol;

    /* Try to load the symbol name as an external function, to see if
       we should bind the symbol to a new function pointer value */
    if(handle==NULL)            /* If no handle */
      handle= dlopen(NULL, RTLD_LAZY);

    mangled= mangle_str(in_string); /* mangle the name */
    funcptr= dlsym(handle, mangled); /* and try to find it */

    dlerr= dlerror();
    if(dlerr != NULL) {         /* If no function was found */
      funcptr= dlsym(handle, in_string); /* Get function pointer */
      dlerr= dlerror();
    }

    if(dlerr==NULL) {           /* If a function was found */
      new_fvalue->type= func;   /* The new value is a function pointer */
      new_fvalue->content.func= funcptr; /* Store function pointer */
      (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
                                         function value */
    }

    free(mangled);
  }

  push_val(env, new_value);
  unprotect(new_value); unprotect(new_fvalue);
}


/* Print a value */
void print_val(environment *env, value *val, int noquote, stackitem *stack, 
               FILE *stream)
{
  stackitem *titem, *tstack;
  int depth;

  switch(val->type) {
  case empty:
    if(fprintf(stream, "[]") < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case integer:
    if(fprintf(stream, "%d", val->content.i) < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case tfloat:
    if(fprintf(stream, "%f", val->content.f) < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case string:
    if(noquote){
      if(fprintf(stream, "%s", val->content.string) < 0){
        perror("print_val");
        env->err= 5;
        return;
      }
    } else {                    /* quote */
      if(fprintf(stream, "\"%s\"", val->content.string) < 0){
        perror("print_val");
        env->err= 5;
        return;
      }
    }
    break;
  case symb:
    if(fprintf(stream, "%s", val->content.sym->id) < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case func:
    if(fprintf(stream, "#<function %p>", val->content.func) < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case port:
    if(fprintf(stream, "#<port %p>", val->content.p) < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    break;
  case tcons:
    if(fprintf(stream, "[ ") < 0){
      perror("print_val");
      env->err= 5;
      return;
    }
    tstack= stack;

    do {
      titem=malloc(sizeof(stackitem));
      assert(titem != NULL);
      titem->item=val;
      titem->next=tstack;
      tstack=titem;             /* Put it on the stack */
      /* Search a stack of values being printed to see if we are already
         printing this value */
      titem=tstack;
      depth=0;

      while(titem != NULL && titem->item != CAR(val)){
        titem=titem->next;
        depth++;
      }

      if(titem != NULL){        /* If we found it on the stack, */
        if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
          perror("print_val");
          env->err= 5;
          free(titem);
          return;
        }
      } else {
        print_val(env, CAR(val), noquote, tstack, stream);
      }

      val= CDR(val);
      switch(val->type){
      case empty:
        break;
      case tcons:
        /* Search a stack of values being printed to see if we are already
           printing this value */
        titem=tstack;
        depth=0;

        while(titem != NULL && titem->item != val){
          titem=titem->next;
          depth++;
        }
        if(titem != NULL){      /* If we found it on the stack, */
          if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
            perror("print_val");
            env->err= 5;
            goto printval_end;
          }
        } else {
          if(fprintf(stream, " ") < 0){
            perror("print_val");
            env->err= 5;
            goto printval_end;
          }
        }
        break;
      default:
        if(fprintf(stream, " . ") < 0){ /* Improper list */
          perror("print_val");
          env->err= 5;
          goto printval_end;
        }
        print_val(env, val, noquote, tstack, stream);
      }
    } while(val->type == tcons && titem == NULL);

  printval_end:

    titem=tstack;
    while(titem != stack){
      tstack=titem->next;
      free(titem);
      titem=tstack;
    }

    if(! (env->err)){
      if(fprintf(stream, " ]") < 0){
        perror("print_val");
        env->err= 5;
      }
    }
    break;
  }
}


/* Swap the two top elements on the stack. */
extern void swap(environment *env)
{
  value *temp= env->head;
  
  if(env->head->type == empty || CDR(env->head)->type == empty) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }

  env->head= CDR(env->head);
  CDR(temp)= CDR(env->head);
  CDR(env->head)= temp;
} 


/* Recall a value from a symbol, if bound */
extern void rcl(environment *env)
{
  value *val;

  if(env->head->type==empty) {
    printerr("Too Few Arguments");
    env->err= 1;
    return;
  }

  if(CAR(env->head)->type!=symb) {
    printerr("Bad Argument Type");
    env->err= 2;
    return;
  }

  val= CAR(env->head)->content.sym->val;
  if(val == NULL){
    printerr("Unbound Variable");
    env->err= 3;
    return;
  }
  push_val(env, val);           /* Return the symbol's bound value */
  swap(env);
  if(env->err) return;
  env->head= CDR(env->head);
}


/* If the top element is a symbol, determine if it's bound to a
   function value, and if it is, toss the symbol and execute the
   function. */
extern void eval(environment *env)
{
  funcp in_func;
  value* temp_val;
  value* iterator;

 eval_start:

  gc_maybe(env);

  if(env->head->type==empty) {
    printerr("Too Few Arguments");
    env->err= 1;
    return;
  }

  switch(CAR(env->head)->type) {
    /* if it's a symbol */
  case symb:
    rcl(env);                   /* get its contents */
    if(env->err) return;
    if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
      goto eval_start;
    }
    return;

    /* If it's a lone function value, run it */
  case func:
    in_func= CAR(env->head)->content.func;
    env->head= CDR(env->head);
    return in_func(env);

    /* If it's a list */
  case tcons:
    temp_val= CAR(env->head);
    protect(temp_val);

    env->head= CDR(env->head);
    iterator= temp_val;
    
    while(iterator->type != empty) {
      push_val(env, CAR(iterator));
      
     if(CAR(env->head)->type==symb
         && CAR(env->head)->content.sym->id[0]==';') {
        env->head= CDR(env->head);
        
        if(CDR(iterator)->type == empty){
          goto eval_start;
        }
        eval(env);
        if(env->err) return;
      }
      if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) 
        iterator= CDR(iterator);
      else {
        printerr("Bad Argument Type"); /* Improper list */
        env->err= 2;
        return;
      }
    }
    unprotect(temp_val);
    return;

  case empty:
    env->head= CDR(env->head);
  case integer:
  case tfloat:
  case string:
  case port:
    return;
  }
}


/* Internal forget function */
void forget_sym(symbol **hash_entry)
{
  symbol *temp;

  temp= *hash_entry;
  *hash_entry= (*hash_entry)->next;
  
  free(temp->id);
  free(temp);
}


int main(int argc, char **argv)
{
  environment myenv;
  int c;                        /* getopt option character */

#ifdef __linux__
  mtrace();
#endif

  init_env(&myenv);

  myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);

  while ((c = getopt (argc, argv, "i")) != -1)
    switch (c)
      {
      case 'i':
        myenv.interactive = 1;
        break;
      case '?':
        fprintf (stderr,
                 "Unknown option character '\\x%x'.\n",
                 optopt);
        return EX_USAGE;
      default:
        abort ();
      }
  
  if (optind < argc) {
    myenv.interactive = 0;
    myenv.inputstream= fopen(argv[optind], "r");
    if(myenv.inputstream== NULL) {
      perror(argv[0]);
      exit (EX_NOINPUT);
    }
  }

  if(myenv.interactive)
    printf(start_message);

  while(1) {
    if(myenv.in_string==NULL) {
      if (myenv.interactive) {
        if(myenv.err) {
          printf("(error %d)\n", myenv.err);
          myenv.err= 0;
        }
        printf("\n");
        printstack(&myenv);
        printf("> ");
      }
      myenv.err=0;
    }
    readstream(&myenv, myenv.inputstream);
    if (myenv.err) {            /* EOF or other error */
      myenv.err=0;
      quit(&myenv);
    } else if(myenv.head->type!=empty
              && CAR(myenv.head)->type==symb
              && CAR(myenv.head)->content.sym->id[0] == ';') {
      if(myenv.head->type != empty)
        myenv.head= CDR(myenv.head);
      eval(&myenv);
    } else {
      gc_maybe(&myenv);
    }
  }
  quit(&myenv);
  return EXIT_FAILURE;
}


/* Return copy of a value */
value *copy_val(environment *env, value *old_value)
{
  value *new_value;

  if(old_value==NULL)
    return NULL;

  new_value= new_val(env);
  new_value->type= old_value->type;

  switch(old_value->type){
  case tfloat:
  case integer:
  case func:
  case symb:
  case empty:
  case port:
    new_value->content= old_value->content;
    break;
  case string:
    new_value->content.string= strdup(old_value->content.string);
    break;
  case tcons:

    new_value->content.c= malloc(sizeof(pair));
    assert(new_value->content.c!=NULL);
    env->gc_count += sizeof(pair);

    CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
    CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
    break;
  }

  return new_value;
}


/* read a line from a stream; used by readline */
void readlinestream(environment *env, FILE *stream)
{
  char in_string[101];

  if(fgets(in_string, 100, stream)==NULL) {
    push_cstring(env, "");
    if (! feof(stream)){
      perror("readline");
      env->err= 5;
    }
  } else {
    push_cstring(env, in_string);
  }
}


/* Reverse (flip) a list */
extern void rev(environment *env)
{
  value *old_head, *new_head, *item;

  if(env->head->type==empty) {
    printerr("Too Few Arguments");
    env->err= 1;
    return;
  }

  if(CAR(env->head)->type==empty)
    return;                     /* Don't reverse an empty list */

  if(CAR(env->head)->type!=tcons) {
    printerr("Bad Argument Type");
    env->err= 2;
    return;
  }

  old_head= CAR(env->head);
  new_head= new_val(env);
  while(old_head->type != empty) {
    item= old_head;
    old_head= CDR(old_head);
    CDR(item)= new_head;
    new_head= item;
  }
  CAR(env->head)= new_head;
}


/* Make a list. */
extern void pack(environment *env)
{
  value *iterator, *temp, *ending;

  ending=new_val(env);

  iterator= env->head;
  if(iterator->type == empty
     || (CAR(iterator)->type==symb
     && CAR(iterator)->content.sym->id[0]=='[')) {
    temp= ending;
    if(env->head->type != empty)
      env->head= CDR(env->head);
  } else {
    /* Search for first delimiter */
    while(CDR(iterator)->type != empty
          && (CAR(CDR(iterator))->type!=symb
           || CAR(CDR(iterator))->content.sym->id[0]!='['))
      iterator= CDR(iterator);
    
    /* Extract list */
    temp= env->head;
    env->head= CDR(iterator);
    CDR(iterator)= ending;

    if(env->head->type != empty)
      env->head= CDR(env->head);
  }

  /* Push list */

  push_val(env, temp);
  rev(env);
}


/* read from a stream; used by "read" and "readport" */
void readstream(environment *env, FILE *stream)
{
  const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
  const char strform[]= "\"%[^\"]\"%n";
  const char intform[]= "%i%n";
  const char fltform[]= "%f%n";
  const char blankform[]= "%*[ \t]%n";
  const char ebrackform[]= "]%n";
  const char semicform[]= ";%n";
  const char bbrackform[]= "[%n";

  int itemp, readlength= -1;
  int count= -1;
  float ftemp;
  static int depth= 0;
  char *match;
  size_t inlength;

  if(env->in_string==NULL) {
    if(depth > 0 && env->interactive) {
      printf("]> ");
    }
    readlinestream(env, env->inputstream);
    if(env->err) return;

    if((CAR(env->head)->content.string)[0]=='\0'){
      env->err= 4;              /* "" means EOF */
      return;
    }
    
    env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
    assert(env->in_string != NULL);
    env->free_string= env->in_string; /* Save the original pointer */
    strcpy(env->in_string, CAR(env->head)->content.string);
    env->head= CDR(env->head);
  }
  
  inlength= strlen(env->in_string)+1;
  match= malloc(inlength);
  assert(match != NULL);

  if(sscanf(env->in_string, blankform, &readlength) != EOF
     && readlength != -1) {
    ; 
  } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
            && readlength != -1) {
    if(sscanf(env->in_string, intform, &itemp, &count) != EOF
       && count==readlength) {
      push_int(env, itemp);
    } else {
      push_float(env, ftemp);
    }
  } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
            && readlength != -1) {
    push_cstring(env, "");
  } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
            && readlength != -1) {
    push_cstring(env, match);
  } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
            && readlength != -1) {
    push_sym(env, match);
  } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
            && readlength != -1) {
    pack(env); if(env->err) return;
    if(depth != 0) depth--;
  } else if(sscanf(env->in_string, semicform, &readlength) != EOF
            && readlength != -1) {
    push_sym(env, ";");
  } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
            && readlength != -1) {
    push_sym(env, "[");
    depth++;
  } else {
    free(env->free_string);
    env->in_string = env->free_string = NULL;
  }
  if (env->in_string != NULL) {
    env->in_string += readlength;
  }

  free(match);

  if(depth)
    return readstream(env, env->inputstream);
}