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>

#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 */
} 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)
{
  long i;

  env->err=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)
{
  long i= 0;
  unsigned long 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) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }

  if(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;
} 

stackitem* copy(stackitem* in_item)
{
  stackitem *out_item= malloc(sizeof(stackitem));

  memcpy(out_item, in_item, sizeof(stackitem));
  out_item->next= NULL;

  return out_item;
}

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

/* 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;
  if(env->head==NULL) {
    printerr("Too Few Arguments");
    env->err=1;
    return;
  }

  /* if it's a symbol */
  if(env->head->item->type==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;
    }
  }

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

/* Reverse 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;
  static int non_eval_flag= 0;

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

  do {
    /* 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(!non_eval_flag) {
          eval(env);            /* Evaluate top element */
          break;
        }
        
        push_sym(env, ";");
        break;
      }

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

      if(*temp=='[') {
        push_sym(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;
  }

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