cvs/stack/stack.c

/* printf */
#include <stdio.h>
/* EXIT_SUCCESS */
#include <stdlib.h>
/* NULL */
#include <stddef.h>
/* dlopen, dlsym, dlerror */
#include <dlfcn.h>
/* assert */
#include <assert.h>
/* strcat */
#include <string.h>

#define HASHTBLSIZE 65536

/* First, define some types. */

/* A value of some type */
typedef struct {
  enum {
    integer,
    string,
    func,                       /* Function pointer */
    symb, 
    list
  } type;                       /* Type of stack element */

  union {
    void *ptr;                  /* Pointer to the content */
    int val;                    /* ...or an integer */
  } content;                    /* Stores a pointer or an integer */

  int refcount;                 /* Reference counter */

} value;

/* A symbol with a name and possible value */
/* (These do not need reference counters, they are kept unique by
   hashing.) */
typedef struct symbol_struct {
  char *id;                     /* Symbol name */
  value *val;                   /* The value (if any) bound to it */
  struct symbol_struct *next;   /* In case of hashing conflicts, a */
} symbol;                       /* symbol is a kind of stack item. */

/* A type for a hash table for symbols */
typedef symbol *hashtbl[HASHTBLSIZE]; /* Hash table declaration */

/* An item (value) on a stack */
typedef struct stackitem_struct
{
  value *item;                  /* The value on the stack */
  struct stackitem_struct *next; /* Next item */
} stackitem;

/* An environment; gives access to the stack and a hash table of
   defined symbols */
typedef struct {
  stackitem *head;              /* Head of the stack */
  hashtbl symbols;              /* Hash table of all variable bindings */
  int err;                      /* Error flag */
  int non_eval_flag;
} environment;

/* A type for pointers to external functions */
typedef void (*funcp)(environment *); /* funcp is a pointer to a void
                                         function (environment *) */

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

  env->err= 0;
  env->non_eval_flag= 0;
  for(i= 0; i<HASHTBLSIZE; i++)
    env->symbols[i]= NULL;
}

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

/* Generic push function. */
void push(stackitem** stack_head, stackitem* in_item)
{
  in_item->next= *stack_head;
  *stack_head= in_item;
}

/* Push a value onto the stack */
void push_val(stackitem **stack_head, value *val)
{
  stackitem *new_item= malloc(sizeof(stackitem));
  new_item->item= val;
  val->refcount++;
  push(stack_head, new_item);
}

/* Push an integer onto the stack. */
void push_int(stackitem **stack_head, int in_val) 
{
  value *new_value= malloc(sizeof(value));
  stackitem *new_item= malloc(sizeof(stackitem));
  new_item->item= new_value;
  
  new_value->content.val= in_val;
  new_value->type= integer;
  new_value->refcount=1;

  push(stack_head, new_item);
}

/* Copy a string onto the stack. */
void push_cstring(stackitem **stack_head, const char *in_string)
{
  value *new_value= malloc(sizeof(value));
  stackitem *new_item= malloc(sizeof(stackitem));
  new_item->item=new_value;

  new_value->content.ptr= malloc(strlen(in_string)+1);
  strcpy(new_value->content.ptr, in_string);
  new_value->type= string;
  new_value->refcount=1;

  push(stack_head, new_item);
}

/* Push a symbol onto the stack. */
void push_sym(environment *env, const char *in_string)
{
  stackitem *new_item;          /* The new stack item */
  /* ...which will contain... */
  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 */

  /* Create a new stack item containing a new value */
  new_item= malloc(sizeof(stackitem));
  new_value= malloc(sizeof(value));
  new_item->item=new_value;

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

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

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

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

    /* Intern the new symbol in the hash table */
    new_value->content.ptr= *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);

    funcptr= dlsym(handle, in_string); /* Get function pointer */
    if(dlerror()==NULL) {       /* If a function was found */
      new_fvalue= malloc(sizeof(value)); /* Create a new value */
      new_fvalue->type=func;    /* The new value is a function pointer */
      new_fvalue->content.ptr=funcptr; /* Store function pointer */
      (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
                                         function value */
      new_fvalue->refcount= 1;
    }
  }
  push(&(env->head), new_item);
}

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

/* Throw away a value */
void free_val(value *val){
  stackitem *item, *temp;

  val->refcount--;              /* Decrease the reference count */
  if(val->refcount == 0){
    switch (val->type){         /* and free the contents if necessary */
    case string:
      free(val->content.ptr);
      break;
    case list:                  /* lists needs to be freed recursively */
      item=val->content.ptr;
      while(item != NULL) {     /* for all stack items */
        free_val(item->item);   /* free the value */
        temp=item->next;        /* save next ptr */
        free(item);             /* free the stackitem */
        item=temp;              /* go to next stackitem */
      }
      free(val);                /* Free the actual list value */
      break;
    default:
      break;
    }
  }
}

/* Discard the top element of the stack. */
extern void toss(environment *env)
{
  stackitem *temp= env->head;

  if((env->head)==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }
  
  free_val(env->head->item);    /* Free the value */
  env->head= env->head->next;   /* Remove the top stack item */
  free(temp);                   /* Free the old top stack item */
}

/* Print newline. */
extern void nl()
{
  printf("\n");
}

/* Gets the type of a value */
extern void type(environment *env){
  int typenum;

  if((env->head)==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }
  typenum=env->head->item->type;
  toss(env);
  switch(typenum){
  case integer:
    push_sym(env, "integer");
    break;
  case string:
    push_sym(env, "string");
    break;
  case symb:
    push_sym(env, "symbol");
    break;
  case func:
    push_sym(env, "function");
    break;
  case list:
    push_sym(env, "list");
    break;
  default:
    push_sym(env, "unknown");
    break;
  }
}    

/* Prints the top element of the stack. */
void print_h(stackitem *stack_head)
{
  switch(stack_head->item->type) {
  case integer:
    printf("%d", stack_head->item->content.val);
    break;
  case string:
    printf("\"%s\"", (char*)stack_head->item->content.ptr);
    break;
  case symb:
    printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);
    break;
  case func:
    printf("#<function %p>", (funcp)(stack_head->item->content.ptr));
    break;
  case list:
    /* A list is just a stack, so make stack_head point to it */
    stack_head=(stackitem *)(stack_head->item->content.ptr);
    printf("[ ");
    while(stack_head != NULL) {
      print_h(stack_head);
      printf(" ");
      stack_head=stack_head->next;
    }
    printf("]");
    break;
  default:
    printf("#<unknown %p>", (stack_head->item->content.ptr));
    break;
  }
}

extern void print_(environment *env) {
  if(env->head==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }
  print_h(env->head);
}

/* Prints the top element of the stack and then discards it. */
extern void print(environment *env)
{
  print_(env);
  if(env->err) return;
  toss(env);
}

/* Only to be called by function printstack. */
void print_st(stackitem *stack_head, long counter)
{ 
  if(stack_head->next != NULL)
    print_st(stack_head->next, counter+1);
  printf("%ld: ", counter);
  print_h(stack_head);
  nl();
}

/* Prints the stack. */
extern void printstack(environment *env)
{
  if(env->head == NULL) {
    return;
  }
  print_st(env->head, 1);
  nl();
}

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

  env->head= env->head->next;
  temp->next= env->head->next;
  env->head->next= temp;
} 

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

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

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

  val=((symbol *)(env->head->item->content.ptr))->val;
  if(val == NULL){
    printerr("Unbound Variable");
    env->err=3;
    return;
  }
  toss(env);            /* toss the symbol */
  if(env->err) return;
  push_val(&(env->head), val); /* Return its bound value */
}

void stack_read(environment*, char*);

/* 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;
  stackitem* iterator;
  char* temp_string;

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

  switch(env->head->item->type) {
    /* if it's a symbol */
  case symb:
    rcl(env);                   /* get its contents */
    if(env->err) return;
    if(env->head->item->type!=symb){ /* don't recurse symbols */
      eval(env);                        /* evaluate the value */
      return;
    }
    break;

    /* If it's a lone function value, run it */
  case func:
    in_func= (funcp)(env->head->item->content.ptr);
    toss(env); 
    if(env->err) return;
    (*in_func)(env);
    break;

    /* If it's a list */
  case list:
    temp_val= env->head->item;
    env->head->item->refcount++;
    toss(env);
    if(env->err) return;
    iterator= (stackitem*)temp_val->content.ptr;
    while(iterator!=NULL && iterator->item!=NULL) {
      push_val(&(env->head), iterator->item);
      if(env->head->item->type==symb
        && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {
        toss(env);
        if(env->err) return;
        eval(env);
        if(env->err) return;
      }
      iterator= iterator->next;
    }
    free_val(temp_val);
    break;

    /* If it's a string */
  case string:
    temp_val= env->head->item;
    env->head->item->refcount++;
    toss(env);
    if(env->err) return;
    temp_string= malloc(strlen((char*)temp_val->content.ptr)+5);
    strcat(temp_string, "[ ");
    strcat(temp_string, (char*)temp_val->content.ptr);
    strcat(temp_string, " ]");
    stack_read(env, temp_string);
    eval(env);
    if(env->err) return;
    free_val(temp_val);
    free(temp_string);
    break;

  default:
  }
}

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

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

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

  old_head=(stackitem *)(env->head->item->content.ptr);
  new_head=NULL;
  while(old_head != NULL){
    item=old_head;
    old_head=old_head->next;
    item->next=new_head;
    new_head=item;
  }
  env->head->item->content.ptr=new_head;
}

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

  delimiter= env->head->item->content.ptr; /* Get delimiter */
  toss(env);

  iterator= env->head;

  if(iterator==NULL || iterator->item->content.ptr==delimiter) {
    temp= NULL;
    toss(env);
  } else {
    /* Search for first delimiter */
    while(iterator->next!=NULL
          && iterator->next->item->content.ptr!=delimiter)
      iterator= iterator->next;
    
    /* Extract list */
    temp= env->head;
    env->head= iterator->next;
    iterator->next= NULL;
    
    if(env->head!=NULL)
      toss(env);
  }

  /* Push list */
  pack= malloc(sizeof(value));
  pack->type= list;
  pack->content.ptr= temp;
  pack->refcount= 1;

  temp= malloc(sizeof(stackitem));
  temp->item= pack;

  push(&(env->head), temp);
  rev(env);
}

/* Parse input. */
void stack_read(environment *env, char *in_line) 
{
  char *temp, *rest;
  int itemp;
  size_t inlength= strlen(in_line)+1;
  int convert= 0;

  temp= malloc(inlength);
  rest= malloc(inlength);

  do {
    /* If comment */
    if((convert= sscanf(in_line, "#%[^\n\r]", rest))) {
      free(temp); free(rest);
      return;
    }

    /* If string */
    if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
      push_cstring(&(env->head), temp);
      break;
    }
    /* If integer */
    if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
      push_int(&(env->head), itemp);
      break;
    }
    /* Escape ';' with '\' */
    if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
      temp[1]= '\0';
      push_sym(env, temp);
      break;
    } 
    /* If symbol */
    if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {
        push_sym(env, temp);
        break;
    }
    /* If single char */
    if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
      if(*temp==';') {
        if(!env->non_eval_flag) {
          eval(env);            /* Evaluate top element */
          break;
        }
        
        push_sym(env, ";");
        break;
      }

      if(*temp==']') {
        push_sym(env, "[");
        pack(env);
        if(env->non_eval_flag)
          env->non_eval_flag--;
        break;
      }

      if(*temp=='[') {
        push_sym(env, "[");
        env->non_eval_flag++;
        break;
      }
    }
  } while(0);

  free(temp);

  if(convert<2) {
    free(rest);
    return;
  }
   
  stack_read(env, rest);
  
  free(rest);
}

/* Relocate elements of the list on the stack. */
extern void expand(environment *env)
{
  stackitem *temp, *new_head;

  /* Is top element a list? */
  if(env->head==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }
  if(env->head->item->type!=list) {
    printerr("Bad Argument Type");
    env->err=2;
    return;
  }

  rev(env);

  if(env->err)
    return;

  /* The first list element is the new stack head */
  new_head= temp= env->head->item->content.ptr;

  env->head->item->refcount++;
  toss(env);

  /* Find the end of the list */
  while(temp->next!=NULL)
    temp= temp->next;

  /* Connect the tail of the list with the old stack head */
  temp->next= env->head;
  env->head= new_head;          /* ...and voila! */

}

/* Compares two elements by reference. */
extern void eq(environment *env)
{
  void *left, *right;
  int result;

  if((env->head)==NULL || env->head->next==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }

  left= env->head->item->content.ptr;
  swap(env);
  right= env->head->item->content.ptr;
  result= (left==right);
  
  toss(env); toss(env);
  push_int(&(env->head), result);
}

/* Negates the top element on the stack. */
extern void not(environment *env)
{
  int val;

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

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

  val= env->head->item->content.val;
  toss(env);
  push_int(&(env->head), !val);
}

/* Compares the two top elements on the stack and return 0 if they're the
   same. */
extern void neq(environment *env)
{
  eq(env);
  not(env);
}

/* Give a symbol some content. */
extern void def(environment *env)
{
  symbol *sym;

  /* Needs two values on the stack, the top one must be a symbol */
  if(env->head==NULL || env->head->next==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }

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

  /* long names are a pain */
  sym=env->head->item->content.ptr;

  /* if the symbol was bound to something else, throw it away */
  if(sym->val != NULL)
    free_val(sym->val);

  /* Bind the symbol to the value */
  sym->val= env->head->next->item;
  sym->val->refcount++;         /* Increase the reference counter */

  toss(env); toss(env);
} 

/* Quit stack. */
extern void quit(environment *env)
{
  exit(EXIT_SUCCESS);
}

/* Clear stack */
extern void clear(environment *env)
{
  while(env->head!=NULL)
    toss(env);
}

/* List all defined words */
extern void words(environment *env)
{
  symbol *temp;
  int i;
  
  for(i= 0; i<HASHTBLSIZE; i++) {
    temp= env->symbols[i];
    while(temp!=NULL) {
      printf("%s\n", temp->id);
      temp= temp->next;
    }
  }
}

/* Forgets a symbol (remove it from the hash table) */
extern void forget(environment *env)
{
  char* sym_id;
  stackitem *stack_head= env->head;
  symbol **hash_entry, *temp;

  if(stack_head==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }
  
  if(stack_head->item->type!=symb) {
    printerr("Bad Argument Type");
    env->err=2;
    return;
  }

  sym_id= ((symbol*)(stack_head->item->content.ptr))->id;
  toss(env);

  hash_entry= hash(env->symbols, sym_id);
  temp= *hash_entry;
  *hash_entry= (*hash_entry)->next;
  
  if(temp->val!=NULL) {
    free_val(temp->val);
  }
  free(temp->id);
  free(temp);
}

/* Returns the current error number to the stack */
extern void errn(environment *env){
  push_int(&(env->head), env->err);
}

int main()
{
  environment myenv;
  char in_string[100];

  init_env(&myenv);

  printf("okidok\n ");

  while(fgets(in_string, 100, stdin) != NULL) {
    stack_read(&myenv, in_string);
    if(myenv.err) {
      printf("(error %d) ", myenv.err);
      myenv.err=0;
    }
    printf("okidok\n ");
  }
  quit(&myenv);
  return EXIT_FAILURE;
}
1	/* printf */
2	#include <stdio.h>
3	/* EXIT_SUCCESS */
4	#include <stdlib.h>
5	/* NULL */
6	#include <stddef.h>
7	/* dlopen, dlsym, dlerror */
8	#include <dlfcn.h>
9	/* assert */
10	#include <assert.h>
11	/* strcat */
12	#include <string.h>
13
14	#define HASHTBLSIZE 65536
15
16	/* First, define some types. */
17
18	/* A value of some type */
19	typedef struct {
20	enum {
21	integer,
22	string,
23	func, /* Function pointer */
24	symb,
25	list
26	} type; /* Type of stack element */
27
28	union {
29	void ptr; / Pointer to the content */
30	int val; /* ...or an integer */
31	} content; /* Stores a pointer or an integer */
32
33	int refcount; /* Reference counter */
34
35	} value;
36
37	/* A symbol with a name and possible value */
38	/* (These do not need reference counters, they are kept unique by
39	hashing.) */
40	typedef struct symbol_struct {
41	char id; / Symbol name */
42	value val; / The value (if any) bound to it */
43	struct symbol_struct next; / In case of hashing conflicts, a */
44	} symbol; /* symbol is a kind of stack item. */
45
46	/* A type for a hash table for symbols */
47	typedef symbol hashtbl[HASHTBLSIZE]; / Hash table declaration */
48
49	/* An item (value) on a stack */
50	typedef struct stackitem_struct
51	{
52	value item; / The value on the stack */
53	struct stackitem_struct next; / Next item */
54	} stackitem;
55
56	/* An environment; gives access to the stack and a hash table of
57	defined symbols */
58	typedef struct {
59	stackitem head; / Head of the stack */
60	hashtbl symbols; /* Hash table of all variable bindings */
61	int err; /* Error flag */
62	int non_eval_flag;
63	} environment;
64
65	/* A type for pointers to external functions */
66	typedef void (funcp)(environment ); /* funcp is a pointer to a void
67	function (environment ) /
68
69	/* Initialize a newly created environment */
70	void init_env(environment *env)
71	{
72	int i;
73
74	env->err= 0;
75	env->non_eval_flag= 0;
76	for(i= 0; i<HASHTBLSIZE; i++)
77	env->symbols[i]= NULL;
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	/* Generic push function. */
110	void push(stackitem** stack_head, stackitem* in_item)
111	{
112	in_item->next= *stack_head;
113	*stack_head= in_item;
114	}
115
116	/* Push a value onto the stack */
117	void push_val(stackitem *stack_head, value val)
118	{
119	stackitem *new_item= malloc(sizeof(stackitem));
120	new_item->item= val;
121	val->refcount++;
122	push(stack_head, new_item);
123	}
124
125	/* Push an integer onto the stack. */
126	void push_int(stackitem **stack_head, int in_val)
127	{
128	value *new_value= malloc(sizeof(value));
129	stackitem *new_item= malloc(sizeof(stackitem));
130	new_item->item= new_value;
131
132	new_value->content.val= in_val;
133	new_value->type= integer;
134	new_value->refcount=1;
135
136	push(stack_head, new_item);
137	}
138
139	/* Copy a string onto the stack. */
140	void push_cstring(stackitem *stack_head, const char in_string)
141	{
142	value *new_value= malloc(sizeof(value));
143	stackitem *new_item= malloc(sizeof(stackitem));
144	new_item->item=new_value;
145
146	new_value->content.ptr= malloc(strlen(in_string)+1);
147	strcpy(new_value->content.ptr, in_string);
148	new_value->type= string;
149	new_value->refcount=1;
150
151	push(stack_head, new_item);
152	}
153
154	/* Push a symbol onto the stack. */
155	void push_sym(environment env, const char in_string)
156	{
157	stackitem new_item; / The new stack item */
158	/* ...which will contain... */
159	value new_value; / A new symbol value */
160	/* ...which might point to... */
161	symbol *new_symbol; / (if needed) A new actual symbol */
162	/* ...which, if possible, will be bound to... */
163	value new_fvalue; / (if needed) A new function value */
164	/* ...which will point to... */
165	void funcptr; / A function pointer */
166
167	static void handle= NULL; / Dynamic linker handle */
168
169	/* Create a new stack item containing a new value */
170	new_item= malloc(sizeof(stackitem));
171	new_value= malloc(sizeof(value));
172	new_item->item=new_value;
173
174	/* The new value is a symbol */
175	new_value->type= symb;
176	new_value->refcount= 1;
177
178	/* Look up the symbol name in the hash table */
179	new_symbol= hash(env->symbols, in_string);
180	new_value->content.ptr= *new_symbol;
181
182	if(new_symbol==NULL) { / If symbol was undefined */
183
184	/* Create a new symbol */
185	(*new_symbol)= malloc(sizeof(symbol));
186	(new_symbol)->val= NULL; / undefined value */
187	(*new_symbol)->next= NULL;
188	(*new_symbol)->id= malloc(strlen(in_string)+1);
189	strcpy((*new_symbol)->id, in_string);
190
191	/* Intern the new symbol in the hash table */
192	new_value->content.ptr= *new_symbol;
193
194	/* Try to load the symbol name as an external function, to see if
195	we should bind the symbol to a new function pointer value */
196	if(handle==NULL) /* If no handle */
197	handle= dlopen(NULL, RTLD_LAZY);
198
199	funcptr= dlsym(handle, in_string); /* Get function pointer */
200	if(dlerror()==NULL) { /* If a function was found */
201	new_fvalue= malloc(sizeof(value)); /* Create a new value */
202	new_fvalue->type=func; /* The new value is a function pointer */
203	new_fvalue->content.ptr=funcptr; /* Store function pointer */
204	(new_symbol)->val= new_fvalue; / Bind the symbol to the new
205	function value */
206	new_fvalue->refcount= 1;
207	}
208	}
209	push(&(env->head), new_item);
210	}
211
212	void printerr(const char* in_string) {
213	fprintf(stderr, "Err: %s\n", in_string);
214	}
215
216	/* Throw away a value */
217	void free_val(value *val){
218	stackitem item, temp;
219
220	val->refcount--; /* Decrease the reference count */
221	if(val->refcount == 0){
222	switch (val->type){ /* and free the contents if necessary */
223	case string:
224	free(val->content.ptr);
225	break;
226	case list: /* lists needs to be freed recursively */
227	item=val->content.ptr;
228	while(item != NULL) { /* for all stack items */
229	free_val(item->item); /* free the value */
230	temp=item->next; /* save next ptr */
231	free(item); /* free the stackitem */
232	item=temp; /* go to next stackitem */
233	}
234	free(val); /* Free the actual list value */
235	break;
236	default:
237	break;
238	}
239	}
240	}
241
242	/* Discard the top element of the stack. */
243	extern void toss(environment *env)
244	{
245	stackitem *temp= env->head;
246
247	if((env->head)==NULL) {
248	printerr("Too Few Arguments");
249	env->err=1;
250	return;
251	}
252
253	free_val(env->head->item); /* Free the value */
254	env->head= env->head->next; /* Remove the top stack item */
255	free(temp); /* Free the old top stack item */
256	}
257
258	/* Print newline. */
259	extern void nl()
260	{
261	printf("\n");
262	}
263
264	/* Gets the type of a value */
265	extern void type(environment *env){
266	int typenum;
267
268	if((env->head)==NULL) {
269	printerr("Too Few Arguments");
270	env->err=1;
271	return;
272	}
273	typenum=env->head->item->type;
274	toss(env);
275	switch(typenum){
276	case integer:
277	push_sym(env, "integer");
278	break;
279	case string:
280	push_sym(env, "string");
281	break;
282	case symb:
283	push_sym(env, "symbol");
284	break;
285	case func:
286	push_sym(env, "function");
287	break;
288	case list:
289	push_sym(env, "list");
290	break;
291	default:
292	push_sym(env, "unknown");
293	break;
294	}
295	}
296
297	/* Prints the top element of the stack. */
298	void print_h(stackitem *stack_head)
299	{
300	switch(stack_head->item->type) {
301	case integer:
302	printf("%d", stack_head->item->content.val);
303	break;
304	case string:
305	printf("\"%s\"", (char*)stack_head->item->content.ptr);
306	break;
307	case symb:
308	printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);
309	break;
310	case func:
311	printf("#<function %p>", (funcp)(stack_head->item->content.ptr));
312	break;
313	case list:
314	/* A list is just a stack, so make stack_head point to it */
315	stack_head=(stackitem *)(stack_head->item->content.ptr);
316	printf("[ ");
317	while(stack_head != NULL) {
318	print_h(stack_head);
319	printf(" ");
320	stack_head=stack_head->next;
321	}
322	printf("]");
323	break;
324	default:
325	printf("#<unknown %p>", (stack_head->item->content.ptr));
326	break;
327	}
328	}
329
330	extern void print_(environment *env) {
331	if(env->head==NULL) {
332	printerr("Too Few Arguments");
333	env->err=1;
334	return;
335	}
336	print_h(env->head);
337	}
338
339	/* Prints the top element of the stack and then discards it. */
340	extern void print(environment *env)
341	{
342	print_(env);
343	if(env->err) return;
344	toss(env);
345	}
346
347	/* Only to be called by function printstack. */
348	void print_st(stackitem *stack_head, long counter)
349	{
350	if(stack_head->next != NULL)
351	print_st(stack_head->next, counter+1);
352	printf("%ld: ", counter);
353	print_h(stack_head);
354	nl();
355	}
356
357	/* Prints the stack. */
358	extern void printstack(environment *env)
359	{
360	if(env->head == NULL) {
361	return;
362	}
363	print_st(env->head, 1);
364	nl();
365	}
366
367	/* Swap the two top elements on the stack. */
368	extern void swap(environment *env)
369	{
370	stackitem *temp= env->head;
371
372	if(env->head==NULL \|\| env->head->next==NULL) {
373	printerr("Too Few Arguments");
374	env->err=1;
375	return;
376	}
377
378	env->head= env->head->next;
379	temp->next= env->head->next;
380	env->head->next= temp;
381	}
382
383	/* Recall a value from a symbol, if bound */
384	extern void rcl(environment *env)
385	{
386	value *val;
387
388	if(env->head == NULL) {
389	printerr("Too Few Arguments");
390	env->err=1;
391	return;
392	}
393
394	if(env->head->item->type!=symb) {
395	printerr("Bad Argument Type");
396	env->err=2;
397	return;
398	}
399
400	val=((symbol *)(env->head->item->content.ptr))->val;
401	if(val == NULL){
402	printerr("Unbound Variable");
403	env->err=3;
404	return;
405	}
406	toss(env); /* toss the symbol */
407	if(env->err) return;
408	push_val(&(env->head), val); /* Return its bound value */
409	}
410
411	void stack_read(environment, char);
412
413	/* If the top element is a symbol, determine if it's bound to a
414	function value, and if it is, toss the symbol and execute the
415	function. */
416	extern void eval(environment *env)
417	{
418	funcp in_func;
419	value* temp_val;
420	stackitem* iterator;
421	char* temp_string;
422
423	if(env->head==NULL) {
424	printerr("Too Few Arguments");
425	env->err=1;
426	return;
427	}
428
429	switch(env->head->item->type) {
430	/* if it's a symbol */
431	case symb:
432	rcl(env); /* get its contents */
433	if(env->err) return;
434	if(env->head->item->type!=symb){ /* don't recurse symbols */
435	eval(env); /* evaluate the value */
436	return;
437	}
438	break;
439
440	/* If it's a lone function value, run it */
441	case func:
442	in_func= (funcp)(env->head->item->content.ptr);
443	toss(env);
444	if(env->err) return;
445	(*in_func)(env);
446	break;
447
448	/* If it's a list */
449	case list:
450	temp_val= env->head->item;
451	env->head->item->refcount++;
452	toss(env);
453	if(env->err) return;
454	iterator= (stackitem*)temp_val->content.ptr;
455	while(iterator!=NULL && iterator->item!=NULL) {
456	push_val(&(env->head), iterator->item);
457	if(env->head->item->type==symb
458	&& strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {
459	toss(env);
460	if(env->err) return;
461	eval(env);
462	if(env->err) return;
463	}
464	iterator= iterator->next;
465	}
466	free_val(temp_val);
467	break;
468
469	/* If it's a string */
470	case string:
471	temp_val= env->head->item;
472	env->head->item->refcount++;
473	toss(env);
474	if(env->err) return;
475	temp_string= malloc(strlen((char*)temp_val->content.ptr)+5);
476	strcat(temp_string, "[ ");
477	strcat(temp_string, (char*)temp_val->content.ptr);
478	strcat(temp_string, " ]");
479	stack_read(env, temp_string);
480	eval(env);
481	if(env->err) return;
482	free_val(temp_val);
483	free(temp_string);
484	break;
485
486	default:
487	}
488	}
489
490	/* Reverse (flip) a list */
491	extern void rev(environment *env){
492	stackitem old_head, new_head, *item;
493
494	if((env->head)==NULL) {
495	printerr("Too Few Arguments");
496	env->err=1;
497	return;
498	}
499
500	if(env->head->item->type!=list) {
501	printerr("Bad Argument Type");
502	env->err=2;
503	return;
504	}
505
506	old_head=(stackitem *)(env->head->item->content.ptr);
507	new_head=NULL;
508	while(old_head != NULL){
509	item=old_head;
510	old_head=old_head->next;
511	item->next=new_head;
512	new_head=item;
513	}
514	env->head->item->content.ptr=new_head;
515	}
516
517	/* Make a list. */
518	extern void pack(environment *env)
519	{
520	void* delimiter;
521	stackitem iterator, temp;
522	value *pack;
523
524	delimiter= env->head->item->content.ptr; /* Get delimiter */
525	toss(env);
526
527	iterator= env->head;
528
529	if(iterator==NULL \|\| iterator->item->content.ptr==delimiter) {
530	temp= NULL;
531	toss(env);
532	} else {
533	/* Search for first delimiter */
534	while(iterator->next!=NULL
535	&& iterator->next->item->content.ptr!=delimiter)
536	iterator= iterator->next;
537
538	/* Extract list */
539	temp= env->head;
540	env->head= iterator->next;
541	iterator->next= NULL;
542
543	if(env->head!=NULL)
544	toss(env);
545	}
546
547	/* Push list */
548	pack= malloc(sizeof(value));
549	pack->type= list;
550	pack->content.ptr= temp;
551	pack->refcount= 1;
552
553	temp= malloc(sizeof(stackitem));
554	temp->item= pack;
555
556	push(&(env->head), temp);
557	rev(env);
558	}
559
560	/* Parse input. */
561	void stack_read(environment env, char in_line)
562	{
563	char temp, rest;
564	int itemp;
565	size_t inlength= strlen(in_line)+1;
566	int convert= 0;
567
568	temp= malloc(inlength);
569	rest= malloc(inlength);
570
571	do {
572	/* If comment */
573	if((convert= sscanf(in_line, "#%[^\n\r]", rest))) {
574	free(temp); free(rest);
575	return;
576	}
577
578	/* If string */
579	if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
580	push_cstring(&(env->head), temp);
581	break;
582	}
583	/* If integer */
584	if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
585	push_int(&(env->head), itemp);
586	break;
587	}
588	/* Escape ';' with '\' */
589	if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
590	temp[1]= '\0';
591	push_sym(env, temp);
592	break;
593	}
594	/* If symbol */
595	if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {
596	push_sym(env, temp);
597	break;
598	}
599	/* If single char */
600	if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
601	if(*temp==';') {
602	if(!env->non_eval_flag) {
603	eval(env); /* Evaluate top element */
604	break;
605	}
606
607	push_sym(env, ";");
608	break;
609	}
610
611	if(*temp==']') {
612	push_sym(env, "[");
613	pack(env);
614	if(env->non_eval_flag)
615	env->non_eval_flag--;
616	break;
617	}
618
619	if(*temp=='[') {
620	push_sym(env, "[");
621	env->non_eval_flag++;
622	break;
623	}
624	}
625	} while(0);
626
627	free(temp);
628
629	if(convert<2) {
630	free(rest);
631	return;
632	}
633
634	stack_read(env, rest);
635
636	free(rest);
637	}
638
639	/* Relocate elements of the list on the stack. */
640	extern void expand(environment *env)
641	{
642	stackitem temp, new_head;
643
644	/* Is top element a list? */
645	if(env->head==NULL) {
646	printerr("Too Few Arguments");
647	env->err=1;
648	return;
649	}
650	if(env->head->item->type!=list) {
651	printerr("Bad Argument Type");
652	env->err=2;
653	return;
654	}
655
656	rev(env);
657
658	if(env->err)
659	return;
660
661	/* The first list element is the new stack head */
662	new_head= temp= env->head->item->content.ptr;
663
664	env->head->item->refcount++;
665	toss(env);
666
667	/* Find the end of the list */
668	while(temp->next!=NULL)
669	temp= temp->next;
670
671	/* Connect the tail of the list with the old stack head */
672	temp->next= env->head;
673	env->head= new_head; /* ...and voila! */
674
675	}
676
677	/* Compares two elements by reference. */
678	extern void eq(environment *env)
679	{
680	void left, right;
681	int result;
682
683	if((env->head)==NULL \|\| env->head->next==NULL) {
684	printerr("Too Few Arguments");
685	env->err=1;
686	return;
687	}
688
689	left= env->head->item->content.ptr;
690	swap(env);
691	right= env->head->item->content.ptr;
692	result= (left==right);
693
694	toss(env); toss(env);
695	push_int(&(env->head), result);
696	}
697
698	/* Negates the top element on the stack. */
699	extern void not(environment *env)
700	{
701	int val;
702
703	if((env->head)==NULL) {
704	printerr("Too Few Arguments");
705	env->err=1;
706	return;
707	}
708
709	if(env->head->item->type!=integer) {
710	printerr("Bad Argument Type");
711	env->err=2;
712	return;
713	}
714
715	val= env->head->item->content.val;
716	toss(env);
717	push_int(&(env->head), !val);
718	}
719
720	/* Compares the two top elements on the stack and return 0 if they're the
721	same. */
722	extern void neq(environment *env)
723	{
724	eq(env);
725	not(env);
726	}
727
728	/* Give a symbol some content. */
729	extern void def(environment *env)
730	{
731	symbol *sym;
732
733	/* Needs two values on the stack, the top one must be a symbol */
734	if(env->head==NULL \|\| env->head->next==NULL) {
735	printerr("Too Few Arguments");
736	env->err=1;
737	return;
738	}
739
740	if(env->head->item->type!=symb) {
741	printerr("Bad Argument Type");
742	env->err=2;
743	return;
744	}
745
746	/* long names are a pain */
747	sym=env->head->item->content.ptr;
748
749	/* if the symbol was bound to something else, throw it away */
750	if(sym->val != NULL)
751	free_val(sym->val);
752
753	/* Bind the symbol to the value */
754	sym->val= env->head->next->item;
755	sym->val->refcount++; /* Increase the reference counter */
756
757	toss(env); toss(env);
758	}
759
760	/* Quit stack. */
761	extern void quit(environment *env)
762	{
763	exit(EXIT_SUCCESS);
764	}
765
766	/* Clear stack */
767	extern void clear(environment *env)
768	{
769	while(env->head!=NULL)
770	toss(env);
771	}
772
773	/* List all defined words */
774	extern void words(environment *env)
775	{
776	symbol *temp;
777	int i;
778
779	for(i= 0; i<HASHTBLSIZE; i++) {
780	temp= env->symbols[i];
781	while(temp!=NULL) {
782	printf("%s\n", temp->id);
783	temp= temp->next;
784	}
785	}
786	}
787
788	/* Forgets a symbol (remove it from the hash table) */
789	extern void forget(environment *env)
790	{
791	char* sym_id;
792	stackitem *stack_head= env->head;
793	symbol *hash_entry, temp;
794
795	if(stack_head==NULL) {
796	printerr("Too Few Arguments");
797	env->err=1;
798	return;
799	}
800
801	if(stack_head->item->type!=symb) {
802	printerr("Bad Argument Type");
803	env->err=2;
804	return;
805	}
806
807	sym_id= ((symbol*)(stack_head->item->content.ptr))->id;
808	toss(env);
809
810	hash_entry= hash(env->symbols, sym_id);
811	temp= *hash_entry;
812	hash_entry= (hash_entry)->next;
813
814	if(temp->val!=NULL) {
815	free_val(temp->val);
816	}
817	free(temp->id);
818	free(temp);
819	}
820
821	/* Returns the current error number to the stack */
822	extern void errn(environment *env){
823	push_int(&(env->head), env->err);
824	}
825
826	int main()
827	{
828	environment myenv;
829	char in_string[100];
830
831	init_env(&myenv);
832
833	printf("okidok\n ");
834
835	while(fgets(in_string, 100, stdin) != NULL) {
836	stack_read(&myenv, in_string);
837	if(myenv.err) {
838	printf("(error %d) ", myenv.err);
839	myenv.err=0;
840	}
841	printf("okidok\n ");
842	}
843	quit(&myenv);
844	return EXIT_FAILURE;
845	}