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,
    ref,                        /* Reference (to an element in the
                                   hash table) */
    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 */
} 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;

  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. */
int push(stackitem** stack_head, stackitem* in_item)
{
  in_item->next= *stack_head;
  *stack_head= in_item;
  return 1;
}

/* 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. */
int 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);
  return 1;
}

/* Copy a string onto the stack. */
int 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);
  return 1;
}

/* Push a symbol onto the stack. */
int 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);
  return 1;
}

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);
    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("Stack empty");
    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");
}

/* Prints the top element of the stack. */
void print_h(stackitem *stack_head)
{

  if(stack_head==NULL) {
    printerr("Stack empty");
    return;
  }

  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;
  default:
    printf("%p", (funcp)(stack_head->item->content.ptr));
    break;
  }
}

extern void print_(environment *env) {
  print_h(env->head);
}

/* Prints the top element of the stack and then discards it. */
extern void print(environment *env)
{
  print_(env);
  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) {
    print_st(env->head, 1);
    nl();
  } else {
    printerr("Stack empty");
  }
}

/* Swap the two top elements on the stack. */
extern void swap(environment *env)
{
  stackitem *temp= env->head;
  
  if((env->head)==NULL) {
    printerr("Stack empty");
    return;
  }

  if(env->head->next==NULL) {
    printerr("Not enough arguments");
    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;
}

extern void rcl(environment *env)
{
  value *val;

  if(env->head == NULL) {
    printerr("Stack empty");
    return;
  }

  if(env->head->item->type!=symb) {
    printerr("Not a symbol");
    return;
  }
  val=((symbol *)(env->head->item->content.ptr))->val;
  toss(env);            /* toss the symbol */
  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;
  value* val;
  if(env->head==NULL) {
    printerr("Stack empty");
    return;
  }

  /* if it's a symbol */
  if(env->head->item->type==symb) {

    /* If it's not bound to anything */
    if (((symbol *)(env->head->item->content.ptr))->val == NULL) {
      printerr("Unbound variable");
      return;
    }
    
    /* If it contains a function */
    if (((symbol *)(env->head->item->content.ptr))->val->type == func) {
      in_func=
        (funcp)(((symbol *)(env->head->item->content.ptr))->val->content.ptr);
      toss(env);
      (*in_func)(env);          /* Run the function */
      return;
    } else {                    /* If it's not a function */
      val=((symbol *)(env->head->item->content.ptr))->val;
      toss(env);                /* toss the symbol */
      push_val(&(env->head), val); /* Return its bound value */
    }
  }

  /* 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); 
    (*in_func)(env);
    return;
  }

}

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

/* Parse input. */
int 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 0;
  }
   
  stack_read(env, rest);
  
  free(rest);
  return 1;
}

/* 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 || env->head->item->type!=list) {
    printerr("Stack empty or not a list");
    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("Not enough elements to compare");
    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 || env->head->item->type!=integer) {
    printerr("Stack empty or element is not a integer");
    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 
     || env->head->item->type!=symb) {
    printerr("Define what?");
    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);
}

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);
    printf("okidok\n ");
  }

  exit(EXIT_SUCCESS);
}
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	ref, /* Reference (to an element in the
22	hash table) */
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	} environment;
62
63	/* A type for pointers to external functions */
64	typedef void (funcp)(environment ); /* funcp is a pointer to a void
65	function (environment ) /
66
67	/* Initialize a newly created environment */
68	void init_env(environment *env)
69	{
70	long i;
71
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	int push(stackitem** stack_head, stackitem* in_item)
107	{
108	in_item->next= *stack_head;
109	*stack_head= in_item;
110	return 1;
111	}
112
113	/* Push a value onto the stack */
114	void push_val(stackitem *stack_head, value val)
115	{
116	stackitem *new_item= malloc(sizeof(stackitem));
117	new_item->item= val;
118	val->refcount++;
119	push(stack_head, new_item);
120	}
121
122	/* Push an integer onto the stack. */
123	int push_int(stackitem **stack_head, int in_val)
124	{
125	value *new_value= malloc(sizeof(value));
126	stackitem *new_item= malloc(sizeof(stackitem));
127	new_item->item= new_value;
128
129	new_value->content.val= in_val;
130	new_value->type= integer;
131	new_value->refcount=1;
132
133	push(stack_head, new_item);
134	return 1;
135	}
136
137	/* Copy a string onto the stack. */
138	int push_cstring(stackitem *stack_head, const char in_string)
139	{
140	value *new_value= malloc(sizeof(value));
141	stackitem *new_item= malloc(sizeof(stackitem));
142	new_item->item=new_value;
143
144	new_value->content.ptr= malloc(strlen(in_string)+1);
145	strcpy(new_value->content.ptr, in_string);
146	new_value->type= string;
147	new_value->refcount=1;
148
149	push(stack_head, new_item);
150	return 1;
151	}
152
153	/* Push a symbol onto the stack. */
154	int push_sym(environment env, const char in_string)
155	{
156	stackitem new_item; / The new stack item */
157	/* ...which will contain... */
158	value new_value; / A new symbol value */
159	/* ...which might point to... */
160	symbol *new_symbol; / (if needed) A new actual symbol */
161	/* ...which, if possible, will be bound to... */
162	value new_fvalue; / (if needed) A new function value */
163	/* ...which will point to... */
164	void funcptr; / A function pointer */
165
166	static void handle= NULL; / Dynamic linker handle */
167
168	/* Create a new stack item containing a new value */
169	new_item= malloc(sizeof(stackitem));
170	new_value= malloc(sizeof(value));
171	new_item->item=new_value;
172
173	/* The new value is a symbol */
174	new_value->type= symb;
175	new_value->refcount= 1;
176
177	/* Look up the symbol name in the hash table */
178	new_symbol= hash(env->symbols, in_string);
179	new_value->content.ptr= *new_symbol;
180
181	if(new_symbol==NULL) { / If symbol was undefined */
182
183	/* Create a new symbol */
184	(*new_symbol)= malloc(sizeof(symbol));
185	(new_symbol)->val= NULL; / undefined value */
186	(*new_symbol)->next= NULL;
187	(*new_symbol)->id= malloc(strlen(in_string)+1);
188	strcpy((*new_symbol)->id, in_string);
189
190	/* Intern the new symbol in the hash table */
191	new_value->content.ptr= *new_symbol;
192
193	/* Try to load the symbol name as an external function, to see if
194	we should bind the symbol to a new function pointer value */
195	if(handle==NULL) /* If no handle */
196	handle= dlopen(NULL, RTLD_LAZY);
197
198	funcptr= dlsym(handle, in_string); /* Get function pointer */
199	if(dlerror()==NULL) { /* If a function was found */
200	new_fvalue= malloc(sizeof(value)); /* Create a new value */
201	new_fvalue->type=func; /* The new value is a function pointer */
202	new_fvalue->content.ptr=funcptr; /* Store function pointer */
203	(new_symbol)->val= new_fvalue; / Bind the symbol to the new
204	function value */
205	new_fvalue->refcount= 1;
206	}
207	}
208	push(&(env->head), new_item);
209	return 1;
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	case list: /* lists needs to be freed recursively */
226	item=val->content.ptr;
227	while(item != NULL) { /* for all stack items */
228	free_val(item->item); /* free the value */
229	temp=item->next; /* save next ptr */
230	free(item); /* free the stackitem */
231	item=temp; /* go to next stackitem */
232	}
233	free(val); /* Free the actual list value */
234	break;
235	default:
236	break;
237	}
238	}
239	}
240
241	/* Discard the top element of the stack. */
242	extern void toss(environment *env)
243	{
244	stackitem *temp= env->head;
245
246	if((env->head)==NULL) {
247	printerr("Stack empty");
248	return;
249	}
250
251	free_val(env->head->item); /* Free the value */
252	env->head= env->head->next; /* Remove the top stack item */
253	free(temp); /* Free the old top stack item */
254	}
255
256	/* Print newline. */
257	extern void nl()
258	{
259	printf("\n");
260	}
261
262	/* Prints the top element of the stack. */
263	void print_h(stackitem *stack_head)
264	{
265
266	if(stack_head==NULL) {
267	printerr("Stack empty");
268	return;
269	}
270
271	switch(stack_head->item->type) {
272	case integer:
273	printf("%d", stack_head->item->content.val);
274	break;
275	case string:
276	printf("\"%s\"", (char*)stack_head->item->content.ptr);
277	break;
278	case symb:
279	printf("'%s'", ((symbol *)(stack_head->item->content.ptr))->id);
280	break;
281	default:
282	printf("%p", (funcp)(stack_head->item->content.ptr));
283	break;
284	}
285	}
286
287	extern void print_(environment *env) {
288	print_h(env->head);
289	}
290
291	/* Prints the top element of the stack and then discards it. */
292	extern void print(environment *env)
293	{
294	print_(env);
295	toss(env);
296	}
297
298	/* Only to be called by function printstack. */
299	void print_st(stackitem *stack_head, long counter)
300	{
301	if(stack_head->next != NULL)
302	print_st(stack_head->next, counter+1);
303	printf("%ld: ", counter);
304	print_h(stack_head);
305	nl();
306	}
307
308
309
310	/* Prints the stack. */
311	extern void printstack(environment *env)
312	{
313	if(env->head != NULL) {
314	print_st(env->head, 1);
315	nl();
316	} else {
317	printerr("Stack empty");
318	}
319	}
320
321	/* Swap the two top elements on the stack. */
322	extern void swap(environment *env)
323	{
324	stackitem *temp= env->head;
325
326	if((env->head)==NULL) {
327	printerr("Stack empty");
328	return;
329	}
330
331	if(env->head->next==NULL) {
332	printerr("Not enough arguments");
333	return;
334	}
335
336	env->head= env->head->next;
337	temp->next= env->head->next;
338	env->head->next= temp;
339	}
340
341	stackitem* copy(stackitem* in_item)
342	{
343	stackitem *out_item= malloc(sizeof(stackitem));
344
345	memcpy(out_item, in_item, sizeof(stackitem));
346	out_item->next= NULL;
347
348	return out_item;
349	}
350
351	extern void rcl(environment *env)
352	{
353	value *val;
354
355	if(env->head == NULL) {
356	printerr("Stack empty");
357	return;
358	}
359
360	if(env->head->item->type!=symb) {
361	printerr("Not a symbol");
362	return;
363	}
364	val=((symbol *)(env->head->item->content.ptr))->val;
365	toss(env); /* toss the symbol */
366	push_val(&(env->head), val); /* Return its bound value */
367	}
368
369	/* If the top element is a symbol, determine if it's bound to a
370	function value, and if it is, toss the symbol and execute the
371	function. */
372	extern void eval(environment *env)
373	{
374	funcp in_func;
375	value* val;
376	if(env->head==NULL) {
377	printerr("Stack empty");
378	return;
379	}
380
381	/* if it's a symbol */
382	if(env->head->item->type==symb) {
383
384	/* If it's not bound to anything */
385	if (((symbol *)(env->head->item->content.ptr))->val == NULL) {
386	printerr("Unbound variable");
387	return;
388	}
389
390	/* If it contains a function */
391	if (((symbol *)(env->head->item->content.ptr))->val->type == func) {
392	in_func=
393	(funcp)(((symbol *)(env->head->item->content.ptr))->val->content.ptr);
394	toss(env);
395	(in_func)(env); / Run the function */
396	return;
397	} else { /* If it's not a function */
398	val=((symbol *)(env->head->item->content.ptr))->val;
399	toss(env); /* toss the symbol */
400	push_val(&(env->head), val); /* Return its bound value */
401	}
402	}
403
404	/* If it's a lone function value, run it */
405	if(env->head->item->type==func) {
406	in_func= (funcp)(env->head->item->content.ptr);
407	toss(env);
408	(*in_func)(env);
409	return;
410	}
411
412	}
413
414	/* Make a list. */
415	extern void pack(environment *env)
416	{
417	void* delimiter;
418	stackitem iterator, temp;
419	value *pack;
420
421	delimiter= env->head->item->content.ptr; /* Get delimiter */
422	toss(env);
423
424	iterator= env->head;
425
426	if(iterator==NULL \|\| iterator->item->content.ptr==delimiter) {
427	temp= NULL;
428	toss(env);
429	} else {
430	/* Search for first delimiter */
431	while(iterator->next!=NULL
432	&& iterator->next->item->content.ptr!=delimiter)
433	iterator= iterator->next;
434
435	/* Extract list */
436	temp= env->head;
437	env->head= iterator->next;
438	iterator->next= NULL;
439
440	if(env->head!=NULL)
441	toss(env);
442	}
443
444	/* Push list */
445	pack= malloc(sizeof(value));
446	pack->type= list;
447	pack->content.ptr= temp;
448	pack->refcount= 1;
449
450	temp= malloc(sizeof(stackitem));
451	temp->item= pack;
452
453	push(&(env->head), temp);
454	}
455
456	/* Parse input. */
457	int stack_read(environment env, char in_line)
458	{
459	char temp, rest;
460	int itemp;
461	size_t inlength= strlen(in_line)+1;
462	int convert= 0;
463	static int non_eval_flag= 0;
464
465	temp= malloc(inlength);
466	rest= malloc(inlength);
467
468	do {
469	/* If string */
470	if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
471	push_cstring(&(env->head), temp);
472	break;
473	}
474	/* If integer */
475	if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
476	push_int(&(env->head), itemp);
477	break;
478	}
479	/* Escape ';' with '\' */
480	if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
481	temp[1]= '\0';
482	push_sym(env, temp);
483	break;
484	}
485	/* If symbol */
486	if((convert= sscanf(in_line, "%[^][ ;\n\r_]%[^\n\r]", temp, rest))) {
487	push_sym(env, temp);
488	break;
489	}
490	/* If single char */
491	if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
492	if(*temp==';') {
493	if(!non_eval_flag) {
494	eval(env); /* Evaluate top element */
495	break;
496	}
497
498	push_sym(env, ";");
499	break;
500	}
501
502	if(*temp==']') {
503	push_sym(env, "[");
504	pack(env);
505	if(non_eval_flag!=0)
506	non_eval_flag--;
507	break;
508	}
509
510	if(*temp=='[') {
511	push_sym(env, "[");
512	non_eval_flag++;
513	break;
514	}
515	}
516	} while(0);
517
518
519	free(temp);
520
521	if(convert<2) {
522	free(rest);
523	return 0;
524	}
525
526	stack_read(env, rest);
527
528	free(rest);
529	return 1;
530	}
531
532	/* Relocate elements of the list on the stack. */
533	extern void expand(environment *env)
534	{
535	stackitem temp, new_head;
536
537	/* Is top element a list? */
538	if(env->head==NULL \|\| env->head->item->type!=list) {
539	printerr("Stack empty or not a list");
540	return;
541	}
542
543	/* The first list element is the new stack head */
544	new_head= temp= env->head->item->content.ptr;
545
546	env->head->item->refcount++;
547	toss(env);
548
549	/* Find the end of the list */
550	while(temp->next!=NULL)
551	temp= temp->next;
552
553	/* Connect the tail of the list with the old stack head */
554	temp->next= env->head;
555	env->head= new_head; /* ...and voila! */
556
557	}
558
559	/* Compares two elements by reference. */
560	extern void eq(environment *env)
561	{
562	void left, right;
563	int result;
564
565	if((env->head)==NULL \|\| env->head->next==NULL) {
566	printerr("Not enough elements to compare");
567	return;
568	}
569
570	left= env->head->item->content.ptr;
571	swap(env);
572	right= env->head->item->content.ptr;
573	result= (left==right);
574
575	toss(env); toss(env);
576	push_int(&(env->head), result);
577	}
578
579	/* Negates the top element on the stack. */
580	extern void not(environment *env)
581	{
582	int val;
583
584	if((env->head)==NULL \|\| env->head->item->type!=integer) {
585	printerr("Stack empty or element is not a integer");
586	return;
587	}
588
589	val= env->head->item->content.val;
590	toss(env);
591	push_int(&(env->head), !val);
592	}
593
594	/* Compares the two top elements on the stack and return 0 if they're the
595	same. */
596	extern void neq(environment *env)
597	{
598	eq(env);
599	not(env);
600	}
601
602	/* Give a symbol some content. */
603	extern void def(environment *env)
604	{
605	symbol *sym;
606
607	/* Needs two values on the stack, the top one must be a symbol */
608	if(env->head==NULL \|\| env->head->next==NULL
609	\|\| env->head->item->type!=symb) {
610	printerr("Define what?");
611	return;
612	}
613
614	/* long names are a pain */
615	sym=env->head->item->content.ptr;
616
617	/* if the symbol was bound to something else, throw it away */
618	if(sym->val != NULL)
619	free_val(sym->val);
620
621	/* Bind the symbol to the value */
622	sym->val= env->head->next->item;
623	sym->val->refcount++; /* Increase the reference counter */
624
625	toss(env); toss(env);
626	}
627
628	/* Quit stack. */
629	extern void quit(environment *env)
630	{
631	exit(EXIT_SUCCESS);
632	}
633
634	/* Clear stack */
635	extern void clear(environment *env)
636	{
637	while(env->head!=NULL)
638	toss(env);
639	}
640
641	int main()
642	{
643	environment myenv;
644	char in_string[100];
645
646	init_env(&myenv);
647
648	printf("okidok\n ");
649
650	while(fgets(in_string, 100, stdin) != NULL) {
651	stack_read(&myenv, in_string);
652	printf("okidok\n ");
653	}
654
655	exit(EXIT_SUCCESS);
656	}