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.136 $\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.";


/* 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(environment *env)
{
  char *in_string;

  switch(env->err) {
  case 0:
    return;
  case 1:
    in_string= "Too Few Arguments";
    break;
  case 2:
    in_string= "Bad Argument Type";
    break;
  case 3:
    in_string= "Unbound Variable";
    break;
  case 5:
    return perror(env->errsymb);
  default:
    in_string= "Unknown error";
    break;
  }

  fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, 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;
}


/* 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);
  new_fvalue= new_val(env);

  /* 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);
}


/* 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)
      env->err= 5;
    break;
  case unknown:
    if(fprintf(stream, "UNKNOWN") < 0)
      env->err= 5;
    break;
  case integer:
    if(fprintf(stream, "%d", val->content.i) < 0)
      env->err= 5;
    break;
  case tfloat:
    if(fprintf(stream, "%f", val->content.f) < 0)
      env->err= 5;
    break;
  case string:
    if(noquote){
      if(fprintf(stream, "%s", val->content.string) < 0)
        env->err= 5;
    } else {                    /* quote */
      if(fprintf(stream, "\"%s\"", val->content.string) < 0)
        env->err= 5;
    }
    break;
  case symb:
    if(fprintf(stream, "%s", val->content.sym->id) < 0)
      env->err= 5;
    break;
  case func:
    if(fprintf(stream, "#<function %p>", val->content.func) < 0)
      env->err= 5;
    break;
  case port:
    if(fprintf(stream, "#<port %p>", val->content.p) < 0)
      env->err= 5;
    break;
  case tcons:
    if(fprintf(stream, "[ ") < 0) {
      env->err= 5;
      return printerr(env);
    }
    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 */
          env->err= 5;
          free(titem);
          return printerr(env);
        }
      } 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 */
            env->err= 5;
            printerr(env);
            goto printval_end;
          }
        } else {
          if(fprintf(stream, " ") < 0){
            env->err= 5;
            printerr(env);
            goto printval_end;
          }
        }
        break;
      default:
        if(fprintf(stream, " . ") < 0){ /* Improper list */
          env->err= 5;
          printerr(env);
          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){
        env->err= 5;
      }
    }
    break;
  }
  
  if(env->err)
    return printerr(env);
}


/* Swap the two top elements on the stack. */
extern void swap(environment *env)
{
  value *temp= env->head;

  if(check_args(env, 2, unknown, unknown))
    return printerr(env);
  
  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(check_args(env, 1, symb))
    return printerr(env);

  val= CAR(env->head)->content.sym->val;
  if(val == NULL){
    env->err= 3;
    return printerr(env);
  }

  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(check_args(env, 1, unknown))
    return printerr(env);

  switch(CAR(env->head)->type) {
    /* if it's a symbol */
  case symb:
    env->errsymb= CAR(env->head)->content.sym->id;
    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((void*)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 {
        env->err= 2; /* Improper list */
        return printerr(env); 
      }
    }
    unprotect(temp_val);
    return;

  case empty:
    env->head= CDR(env->head);
  case integer:
  case tfloat:
  case string:
  case port:
  case unknown:
    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)
    puts(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 unknown:
  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)){
      env->err= 5;
      return printerr(env);
    }
  } else {
    push_cstring(env, in_string);
  }
}


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

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

  if(check_args(env, 1, tcons))
    return printerr(env);

  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);
}


int check_args(environment *env, int num_args, ...)
{
  va_list ap;
  enum type_enum mytype;
  int i;

  value *iter= env->head;
  int errval= 0;

  va_start(ap, num_args);
  for(i=1; i<=num_args; i++) {
    mytype= va_arg(ap, enum type_enum);
    //    fprintf(stderr, "%s\n", env->errsymb); 

    if(iter->type==empty || iter==NULL) {
      errval= 1;
      break;
    }

    if(mytype!=unknown && CAR(iter)->type!=mytype) {
      errval= 2;
      break;
    }

    iter= CDR(iter);
  }

  va_end(ap);

  env->err= errval;
  return errval;
}
1	/* -- coding: utf-8; -- */
2	/*
3	stack - an interactive interpreter for a stack-based language
4	Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn
5
6	This program is free software; you can redistribute it and/or modify
7	it under the terms of the GNU General Public License as published by
8	the Free Software Foundation; either version 2 of the License, or
9	(at your option) any later version.
10
11	This program is distributed in the hope that it will be useful,
12	but WITHOUT ANY WARRANTY; without even the implied warranty of
13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14	GNU General Public License for more details.
15
16	You should have received a copy of the GNU General Public License
17	along with this program; if not, write to the Free Software
18	Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
20	Authors: Mats Alritzson <masse@fukt.bth.se>
21	Teddy Hogeborn <teddy@fukt.bth.se>
22	*/
23
24	#include "stack.h"
25
26	const char* start_message= "Stack version $Revision: 1.136 $\n\
27	Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\
28	Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
29	This is free software, and you are welcome to redistribute it\n\
30	under certain conditions; type 'copying;' for details.";
31
32
33	/* Initialize a newly created environment */
34	void init_env(environment *env)
35	{
36	int i;
37
38	env->gc_limit= 400000;
39	env->gc_count= 0;
40	env->gc_ref= NULL;
41
42	env->head= new_val(env);
43	for(i= 0; i<HASHTBLSIZE; i++)
44	env->symbols[i]= NULL;
45	env->err= 0;
46	env->in_string= NULL;
47	env->free_string= NULL;
48	env->inputstream= stdin;
49	env->interactive= 1;
50	}
51
52
53	void printerr(environment *env)
54	{
55	char *in_string;
56
57	switch(env->err) {
58	case 0:
59	return;
60	case 1:
61	in_string= "Too Few Arguments";
62	break;
63	case 2:
64	in_string= "Bad Argument Type";
65	break;
66	case 3:
67	in_string= "Unbound Variable";
68	break;
69	case 5:
70	return perror(env->errsymb);
71	default:
72	in_string= "Unknown error";
73	break;
74	}
75
76	fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
77	}
78
79
80	/* Returns a pointer to a pointer to an element in the hash table. */
81	symbol *hash(hashtbl in_hashtbl, const char in_string)
82	{
83	int i= 0;
84	unsigned int out_hash= 0;
85	char key= '\0';
86	symbol **position;
87
88	while(1){ /* Hash in_string */
89	key= in_string[i++];
90	if(key=='\0')
91	break;
92	out_hash= out_hash*32+key;
93	}
94
95	out_hash= out_hash%HASHTBLSIZE;
96	position= &(in_hashtbl[out_hash]);
97
98	while(1){
99	if(position==NULL) / If empty */
100	return position;
101
102	if(strcmp(in_string, (position)->id)==0) / If match */
103	return position;
104
105	position= &((position)->next); / Try next */
106	}
107	}
108
109
110	/* Create new value */
111	value* new_val(environment *env)
112	{
113	value *nval= malloc(sizeof(value));
114	stackitem *nitem= malloc(sizeof(stackitem));
115
116	assert(nval != NULL);
117	assert(nitem != NULL);
118
119	nval->content.ptr= NULL;
120	nval->type= empty;
121
122	nitem->item= nval;
123	nitem->next= env->gc_ref;
124
125	env->gc_ref= nitem;
126
127	env->gc_count += sizeof(value);
128	nval->gc.flag.mark= 0;
129	nval->gc.flag.protect= 0;
130
131	return nval;
132	}
133
134
135	/* Push a value onto the stack */
136	void push_val(environment env, value val)
137	{
138	value *new_value= new_val(env);
139
140	new_value->content.c= malloc(sizeof(pair));
141	assert(new_value->content.c!=NULL);
142	env->gc_count += sizeof(pair);
143	new_value->type= tcons;
144	CAR(new_value)= val;
145	CDR(new_value)= env->head;
146	env->head= new_value;
147	}
148
149
150	/* Push an integer onto the stack */
151	void push_int(environment *env, int in_val)
152	{
153	value *new_value= new_val(env);
154
155	new_value->content.i= in_val;
156	new_value->type= integer;
157
158	push_val(env, new_value);
159	}
160
161
162	/* Push a floating point number onto the stack */
163	void push_float(environment *env, float in_val)
164	{
165	value *new_value= new_val(env);
166
167	new_value->content.f= in_val;
168	new_value->type= tfloat;
169
170	push_val(env, new_value);
171	}
172
173
174	/* Copy a string onto the stack. */
175	void push_cstring(environment env, const char in_string)
176	{
177	value *new_value= new_val(env);
178	int length= strlen(in_string)+1;
179
180	new_value->content.string= malloc(length);
181	assert(new_value != NULL);
182	env->gc_count += length;
183	strcpy(new_value->content.string, in_string);
184	new_value->type= string;
185
186	push_val(env, new_value);
187	}
188
189
190	/* Mangle a symbol name to a valid C identifier name */
191	char mangle_str(const char old_string)
192	{
193	char validchars[]= "0123456789abcdef";
194	char new_string, current;
195
196	new_string= malloc((strlen(old_string)*2)+4);
197	assert(new_string != NULL);
198	strcpy(new_string, "sx_"); /* Stack eXternal */
199	current= new_string+3;
200
201	while(old_string[0] != '\0'){
202	current[0]= validchars[(unsigned char)(old_string[0])/16];
203	current[1]= validchars[(unsigned char)(old_string[0])%16];
204	current+= 2;
205	old_string++;
206	}
207	current[0]= '\0';
208
209	return new_string; /* The caller must free() it */
210	}
211
212
213	/* Push a symbol onto the stack. */
214	void push_sym(environment env, const char in_string)
215	{
216	value new_value; / A new symbol value */
217	/* ...which might point to... */
218	symbol *new_symbol; / (if needed) A new actual symbol */
219	/* ...which, if possible, will be bound to... */
220	value new_fvalue; / (if needed) A new function value */
221	/* ...which will point to... */
222	void funcptr; / A function pointer */
223
224	static void handle= NULL; / Dynamic linker handle */
225	const char dlerr; / Dynamic linker error */
226	char mangled; / Mangled function name */
227
228	new_value= new_val(env);
229	new_fvalue= new_val(env);
230
231	/* The new value is a symbol */
232	new_value->type= symb;
233
234	/* Look up the symbol name in the hash table */
235	new_symbol= hash(env->symbols, in_string);
236	new_value->content.sym= *new_symbol;
237
238	if(new_symbol==NULL) { / If symbol was undefined */
239
240	/* Create a new symbol */
241	(*new_symbol)= malloc(sizeof(symbol));
242	assert((*new_symbol) != NULL);
243	(new_symbol)->val= NULL; / undefined value */
244	(*new_symbol)->next= NULL;
245	(*new_symbol)->id= malloc(strlen(in_string)+1);
246	assert((*new_symbol)->id != NULL);
247	strcpy((*new_symbol)->id, in_string);
248
249	/* Intern the new symbol in the hash table */
250	new_value->content.sym= *new_symbol;
251
252	/* Try to load the symbol name as an external function, to see if
253	we should bind the symbol to a new function pointer value */
254	if(handle==NULL) /* If no handle */
255	handle= dlopen(NULL, RTLD_LAZY);
256
257	mangled= mangle_str(in_string); /* mangle the name */
258	funcptr= dlsym(handle, mangled); /* and try to find it */
259
260	dlerr= dlerror();
261	if(dlerr != NULL) { /* If no function was found */
262	funcptr= dlsym(handle, in_string); /* Get function pointer */
263	dlerr= dlerror();
264	}
265
266	if(dlerr==NULL) { /* If a function was found */
267	new_fvalue->type= func; /* The new value is a function pointer */
268	new_fvalue->content.func= funcptr; /* Store function pointer */
269	(new_symbol)->val= new_fvalue; / Bind the symbol to the new
270	function value */
271	}
272
273	free(mangled);
274	}
275
276	push_val(env, new_value);
277	}
278
279
280	/* Print a value */
281	void print_val(environment env, value val, int noquote, stackitem *stack,
282	FILE *stream)
283	{
284	stackitem titem, tstack;
285	int depth;
286
287	switch(val->type) {
288	case empty:
289	if(fprintf(stream, "[]") < 0)
290	env->err= 5;
291	break;
292	case unknown:
293	if(fprintf(stream, "UNKNOWN") < 0)
294	env->err= 5;
295	break;
296	case integer:
297	if(fprintf(stream, "%d", val->content.i) < 0)
298	env->err= 5;
299	break;
300	case tfloat:
301	if(fprintf(stream, "%f", val->content.f) < 0)
302	env->err= 5;
303	break;
304	case string:
305	if(noquote){
306	if(fprintf(stream, "%s", val->content.string) < 0)
307	env->err= 5;
308	} else { /* quote */
309	if(fprintf(stream, "\"%s\"", val->content.string) < 0)
310	env->err= 5;
311	}
312	break;
313	case symb:
314	if(fprintf(stream, "%s", val->content.sym->id) < 0)
315	env->err= 5;
316	break;
317	case func:
318	if(fprintf(stream, "#<function %p>", val->content.func) < 0)
319	env->err= 5;
320	break;
321	case port:
322	if(fprintf(stream, "#<port %p>", val->content.p) < 0)
323	env->err= 5;
324	break;
325	case tcons:
326	if(fprintf(stream, "[ ") < 0) {
327	env->err= 5;
328	return printerr(env);
329	}
330	tstack= stack;
331
332	do {
333	titem=malloc(sizeof(stackitem));
334	assert(titem != NULL);
335	titem->item=val;
336	titem->next=tstack;
337	tstack=titem; /* Put it on the stack */
338	/* Search a stack of values being printed to see if we are already
339	printing this value */
340	titem=tstack;
341	depth=0;
342
343	while(titem != NULL && titem->item != CAR(val)){
344	titem=titem->next;
345	depth++;
346	}
347
348	if(titem != NULL){ /* If we found it on the stack, */
349	if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
350	env->err= 5;
351	free(titem);
352	return printerr(env);
353	}
354	} else {
355	print_val(env, CAR(val), noquote, tstack, stream);
356	}
357
358	val= CDR(val);
359	switch(val->type){
360	case empty:
361	break;
362	case tcons:
363	/* Search a stack of values being printed to see if we are already
364	printing this value */
365	titem=tstack;
366	depth=0;
367
368	while(titem != NULL && titem->item != val){
369	titem=titem->next;
370	depth++;
371	}
372	if(titem != NULL){ /* If we found it on the stack, */
373	if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
374	env->err= 5;
375	printerr(env);
376	goto printval_end;
377	}
378	} else {
379	if(fprintf(stream, " ") < 0){
380	env->err= 5;
381	printerr(env);
382	goto printval_end;
383	}
384	}
385	break;
386	default:
387	if(fprintf(stream, " . ") < 0){ /* Improper list */
388	env->err= 5;
389	printerr(env);
390	goto printval_end;
391	}
392	print_val(env, val, noquote, tstack, stream);
393	}
394	} while(val->type == tcons && titem == NULL);
395
396	printval_end:
397
398	titem=tstack;
399	while(titem != stack){
400	tstack=titem->next;
401	free(titem);
402	titem=tstack;
403	}
404
405	if(! (env->err)){
406	if(fprintf(stream, " ]") < 0){
407	env->err= 5;
408	}
409	}
410	break;
411	}
412
413	if(env->err)
414	return printerr(env);
415	}
416
417
418	/* Swap the two top elements on the stack. */
419	extern void swap(environment *env)
420	{
421	value *temp= env->head;
422
423	if(check_args(env, 2, unknown, unknown))
424	return printerr(env);
425
426	env->head= CDR(env->head);
427	CDR(temp)= CDR(env->head);
428	CDR(env->head)= temp;
429	}
430
431
432	/* Recall a value from a symbol, if bound */
433	extern void rcl(environment *env)
434	{
435	value *val;
436
437	if(check_args(env, 1, symb))
438	return printerr(env);
439
440	val= CAR(env->head)->content.sym->val;
441	if(val == NULL){
442	env->err= 3;
443	return printerr(env);
444	}
445
446	push_val(env, val); /* Return the symbol's bound value */
447	swap(env);
448	if(env->err) return;
449	env->head= CDR(env->head);
450	}
451
452
453	/* If the top element is a symbol, determine if it's bound to a
454	function value, and if it is, toss the symbol and execute the
455	function. */
456	extern void eval(environment *env)
457	{
458	funcp in_func;
459	value* temp_val;
460	value* iterator;
461
462	eval_start:
463
464	gc_maybe(env);
465
466	if(check_args(env, 1, unknown))
467	return printerr(env);
468
469	switch(CAR(env->head)->type) {
470	/* if it's a symbol */
471	case symb:
472	env->errsymb= CAR(env->head)->content.sym->id;
473	rcl(env); /* get its contents */
474	if(env->err) return;
475	if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
476	goto eval_start;
477	}
478	return;
479
480	/* If it's a lone function value, run it */
481	case func:
482	in_func= CAR(env->head)->content.func;
483	env->head= CDR(env->head);
484	return in_func((void*)env);
485
486	/* If it's a list */
487	case tcons:
488	temp_val= CAR(env->head);
489	protect(temp_val);
490
491	env->head= CDR(env->head);
492	iterator= temp_val;
493
494	while(iterator->type != empty) {
495	push_val(env, CAR(iterator));
496
497	if(CAR(env->head)->type==symb
498	&& CAR(env->head)->content.sym->id[0]==';') {
499	env->head= CDR(env->head);
500
501	if(CDR(iterator)->type == empty){
502	goto eval_start;
503	}
504	eval(env);
505	if(env->err) return;
506	}
507	if (CDR(iterator)->type == empty \|\| CDR(iterator)->type == tcons)
508	iterator= CDR(iterator);
509	else {
510	env->err= 2; /* Improper list */
511	return printerr(env);
512	}
513	}
514	unprotect(temp_val);
515	return;
516
517	case empty:
518	env->head= CDR(env->head);
519	case integer:
520	case tfloat:
521	case string:
522	case port:
523	case unknown:
524	return;
525	}
526	}
527
528
529	/* Internal forget function */
530	void forget_sym(symbol **hash_entry)
531	{
532	symbol *temp;
533
534	temp= *hash_entry;
535	hash_entry= (hash_entry)->next;
536
537	free(temp->id);
538	free(temp);
539	}
540
541
542	int main(int argc, char **argv)
543	{
544	environment myenv;
545	int c; /* getopt option character */
546
547	#ifdef __linux__
548	mtrace();
549	#endif
550
551	init_env(&myenv);
552
553	myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
554
555	while ((c = getopt (argc, argv, "i")) != -1)
556	switch (c)
557	{
558	case 'i':
559	myenv.interactive = 1;
560	break;
561	case '?':
562	fprintf (stderr,
563	"Unknown option character '\\x%x'.\n",
564	optopt);
565	return EX_USAGE;
566	default:
567	abort ();
568	}
569
570	if (optind < argc) {
571	myenv.interactive = 0;
572	myenv.inputstream= fopen(argv[optind], "r");
573	if(myenv.inputstream== NULL) {
574	perror(argv[0]);
575	exit (EX_NOINPUT);
576	}
577	}
578
579	if(myenv.interactive)
580	puts(start_message);
581
582	while(1) {
583	if(myenv.in_string==NULL) {
584	if (myenv.interactive) {
585	if(myenv.err) {
586	printf("(error %d)\n", myenv.err);
587	myenv.err= 0;
588	}
589	printf("\n");
590	printstack(&myenv);
591	printf("> ");
592	}
593	myenv.err=0;
594	}
595	readstream(&myenv, myenv.inputstream);
596	if (myenv.err) { /* EOF or other error */
597	myenv.err=0;
598	quit(&myenv);
599	} else if(myenv.head->type!=empty
600	&& CAR(myenv.head)->type==symb
601	&& CAR(myenv.head)->content.sym->id[0] == ';') {
602	if(myenv.head->type != empty)
603	myenv.head= CDR(myenv.head);
604	eval(&myenv);
605	} else {
606	gc_maybe(&myenv);
607	}
608	}
609	quit(&myenv);
610	return EXIT_FAILURE;
611	}
612
613
614	/* Return copy of a value */
615	value copy_val(environment env, value *old_value)
616	{
617	value *new_value;
618
619	if(old_value==NULL)
620	return NULL;
621
622	new_value= new_val(env);
623	new_value->type= old_value->type;
624
625	switch(old_value->type){
626	case tfloat:
627	case integer:
628	case func:
629	case symb:
630	case empty:
631	case unknown:
632	case port:
633	new_value->content= old_value->content;
634	break;
635	case string:
636	new_value->content.string= strdup(old_value->content.string);
637	break;
638	case tcons:
639
640	new_value->content.c= malloc(sizeof(pair));
641	assert(new_value->content.c!=NULL);
642	env->gc_count += sizeof(pair);
643
644	CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
645	CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
646	break;
647	}
648
649	return new_value;
650	}
651
652
653	/* read a line from a stream; used by readline */
654	void readlinestream(environment env, FILE stream)
655	{
656	char in_string[101];
657
658	if(fgets(in_string, 100, stream)==NULL) {
659	push_cstring(env, "");
660	if (! feof(stream)){
661	env->err= 5;
662	return printerr(env);
663	}
664	} else {
665	push_cstring(env, in_string);
666	}
667	}
668
669
670	/* Reverse (flip) a list */
671	extern void rev(environment *env)
672	{
673	value old_head, new_head, *item;
674
675	if(CAR(env->head)->type==empty)
676	return; /* Don't reverse an empty list */
677
678	if(check_args(env, 1, tcons))
679	return printerr(env);
680
681	old_head= CAR(env->head);
682	new_head= new_val(env);
683	while(old_head->type != empty) {
684	item= old_head;
685	old_head= CDR(old_head);
686	CDR(item)= new_head;
687	new_head= item;
688	}
689	CAR(env->head)= new_head;
690	}
691
692
693	/* Make a list. */
694	extern void pack(environment *env)
695	{
696	value iterator, temp, *ending;
697
698	ending=new_val(env);
699
700	iterator= env->head;
701	if(iterator->type == empty
702	\|\| (CAR(iterator)->type==symb
703	&& CAR(iterator)->content.sym->id[0]=='[')) {
704	temp= ending;
705	if(env->head->type != empty)
706	env->head= CDR(env->head);
707	} else {
708	/* Search for first delimiter */
709	while(CDR(iterator)->type != empty
710	&& (CAR(CDR(iterator))->type!=symb
711	\|\| CAR(CDR(iterator))->content.sym->id[0]!='['))
712	iterator= CDR(iterator);
713
714	/* Extract list */
715	temp= env->head;
716	env->head= CDR(iterator);
717	CDR(iterator)= ending;
718
719	if(env->head->type != empty)
720	env->head= CDR(env->head);
721	}
722
723	/* Push list */
724
725	push_val(env, temp);
726	rev(env);
727	}
728
729
730	/* read from a stream; used by "read" and "readport" */
731	void readstream(environment env, FILE stream)
732	{
733	const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
734	const char strform[]= "\"%[^\"]\"%n";
735	const char intform[]= "%i%n";
736	const char fltform[]= "%f%n";
737	const char blankform[]= "%*[ \t]%n";
738	const char ebrackform[]= "]%n";
739	const char semicform[]= ";%n";
740	const char bbrackform[]= "[%n";
741
742	int itemp, readlength= -1;
743	int count= -1;
744	float ftemp;
745	static int depth= 0;
746	char *match;
747	size_t inlength;
748
749	if(env->in_string==NULL) {
750	if(depth > 0 && env->interactive) {
751	printf("]> ");
752	}
753	readlinestream(env, env->inputstream);
754	if(env->err) return;
755
756	if((CAR(env->head)->content.string)[0]=='\0'){
757	env->err= 4; /* "" means EOF */
758	return;
759	}
760
761	env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
762	assert(env->in_string != NULL);
763	env->free_string= env->in_string; /* Save the original pointer */
764	strcpy(env->in_string, CAR(env->head)->content.string);
765	env->head= CDR(env->head);
766	}
767
768	inlength= strlen(env->in_string)+1;
769	match= malloc(inlength);
770	assert(match != NULL);
771
772	if(sscanf(env->in_string, blankform, &readlength) != EOF
773	&& readlength != -1) {
774	;
775	} else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
776	&& readlength != -1) {
777	if(sscanf(env->in_string, intform, &itemp, &count) != EOF
778	&& count==readlength) {
779	push_int(env, itemp);
780	} else {
781	push_float(env, ftemp);
782	}
783	} else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
784	&& readlength != -1) {
785	push_cstring(env, "");
786	} else if(sscanf(env->in_string, strform, match, &readlength) != EOF
787	&& readlength != -1) {
788	push_cstring(env, match);
789	} else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
790	&& readlength != -1) {
791	push_sym(env, match);
792	} else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
793	&& readlength != -1) {
794	pack(env); if(env->err) return;
795	if(depth != 0) depth--;
796	} else if(sscanf(env->in_string, semicform, &readlength) != EOF
797	&& readlength != -1) {
798	push_sym(env, ";");
799	} else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
800	&& readlength != -1) {
801	push_sym(env, "[");
802	depth++;
803	} else {
804	free(env->free_string);
805	env->in_string = env->free_string = NULL;
806	}
807	if (env->in_string != NULL) {
808	env->in_string += readlength;
809	}
810
811	free(match);
812
813	if(depth)
814	return readstream(env, env->inputstream);
815	}
816
817
818	int check_args(environment *env, int num_args, ...)
819	{
820	va_list ap;
821	enum type_enum mytype;
822	int i;
823
824	value *iter= env->head;
825	int errval= 0;
826
827	va_start(ap, num_args);
828	for(i=1; i<=num_args; i++) {
829	mytype= va_arg(ap, enum type_enum);
830	// fprintf(stderr, "%s\n", env->errsymb);
831
832	if(iter->type==empty \|\| iter==NULL) {
833	errval= 1;
834	break;
835	}
836
837	if(mytype!=unknown && CAR(iter)->type!=mytype) {
838	errval= 2;
839	break;
840	}
841
842	iter= CDR(iter);
843	}
844
845	va_end(ap);
846
847	env->err= errval;
848	return errval;
849	}