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 an integer onto the stack. */
int push_val(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_value->content.ptr= *hash(env->symbols, in_string);

  if(new_value->content.ptr==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;
}


/* If the top element is a reference, determine if it's a reference to a
   function, and if it is, toss the reference and execute the function. */
extern void eval(environment *env)
{
  funcp in_func;
  stackitem* temp= env->head;

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

  if(temp->item->type==symb
     && ((symbol *)(temp->item->content.ptr))->val != NULL
     && ((symbol *)(temp->item->content.ptr))->val->type == func) {
    in_func= (funcp)(((symbol *)(temp->item->content.ptr))->val->content.ptr);
    toss(env);
    (*in_func)(env);
    return;
  }
    

  if(temp->item->type==func) {
    in_func= (funcp)(temp->item->content.ptr);
    toss(env); 
    (*in_func)(env);
    return;
  }

  push(&(env->head), copy(temp));
  swap(env);
  toss(env);
}

/* 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_val(&(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_val(&(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_val(&(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	masse	1.1	/* printf */
2			#include <stdio.h>
3			/* EXIT_SUCCESS */
4			#include <stdlib.h>
5			/* NULL */
6			#include <stddef.h>
7	teddy	1.3	/* dlopen, dlsym, dlerror */
8	masse	1.1	#include <dlfcn.h>
9	teddy	1.18	/* assert */
10			#include <assert.h>
11	masse	1.1
12			#define HASHTBLSIZE 65536
13
14	teddy	1.28	/* First, define some types. */
15
16			/* A value of some type */
17			typedef struct {
18	masse	1.16	enum {
19	teddy	1.28	integer,
20	teddy	1.18	string,
21			ref, /* Reference (to an element in the
22			hash table) */
23	masse	1.16	func, /* Function pointer */
24	teddy	1.28	symb,
25	masse	1.16	list
26	teddy	1.18	} type; /* Type of stack element */
27
28	masse	1.1	union {
29	teddy	1.28	void ptr; / Pointer to the content */
30	masse	1.16	int val; /* ...or an integer */
31			} content; /* Stores a pointer or an integer */
32	masse	1.1
33	teddy	1.28	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	masse	1.1	} stackitem;
55
56	teddy	1.28	/* 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	masse	1.1
67	teddy	1.28	/* Initialize a newly created environment */
68			void init_env(environment *env)
69	masse	1.1	{
70			long i;
71
72			for(i= 0; i<HASHTBLSIZE; i++)
73	teddy	1.28	env->symbols[i]= NULL;
74	masse	1.1	}
75
76	teddy	1.27	/* Returns a pointer to a pointer to an element in the hash table. */
77	teddy	1.28	symbol *hash(hashtbl in_hashtbl, const char in_string)
78	masse	1.1	{
79			long i= 0;
80			unsigned long out_hash= 0;
81	teddy	1.18	char key= '\0';
82	teddy	1.28	symbol **position;
83	masse	1.1
84	masse	1.16	while(1){ /* Hash in_string */
85	masse	1.1	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	masse	1.25	while(1){
95	teddy	1.18	if(position==NULL) / If empty */
96	masse	1.1	return position;
97
98	teddy	1.18	if(strcmp(in_string, (position)->id)==0) / If match */
99	masse	1.1	return position;
100
101	masse	1.16	position= &((position)->next); / Try next */
102	masse	1.1	}
103			}
104
105	masse	1.14	/* Generic push function. */
106	masse	1.1	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	teddy	1.28	/* Push an integer onto the stack. */
114			int push_val(stackitem **stack_head, int in_val)
115	masse	1.1	{
116	teddy	1.28	value *new_value= malloc(sizeof(value));
117			stackitem *new_item= malloc(sizeof(stackitem));
118			new_item->item= new_value;
119
120			new_value->content.val= in_val;
121			new_value->type= integer;
122			new_value->refcount=1;
123	masse	1.1
124			push(stack_head, new_item);
125			return 1;
126			}
127
128	masse	1.14	/* Copy a string onto the stack. */
129	teddy	1.28	int push_cstring(stackitem *stack_head, const char in_string)
130	masse	1.1	{
131	teddy	1.28	value *new_value= malloc(sizeof(value));
132			stackitem *new_item= malloc(sizeof(stackitem));
133			new_item->item=new_value;
134
135			new_value->content.ptr= malloc(strlen(in_string)+1);
136			strcpy(new_value->content.ptr, in_string);
137			new_value->type= string;
138			new_value->refcount=1;
139	masse	1.1
140			push(stack_head, new_item);
141			return 1;
142			}
143
144	teddy	1.28	/* Push a symbol onto the stack. */
145			int push_sym(environment env, const char in_string)
146	masse	1.1	{
147	teddy	1.28	stackitem new_item; / The new stack item */
148			/* ...which will contain... */
149			value new_value; / A new symbol value */
150			/* ...which might point to... */
151			symbol new_symbol; / (if needed) A new actual symbol */
152			/* ...which, if possible, will be bound to... */
153			value new_fvalue; / (if needed) A new function value */
154			/* ...which will point to... */
155			void funcptr; / A function pointer */
156
157			static void handle= NULL; / Dynamic linker handle */
158
159			/* Create a new stack item containing a new value */
160			new_item= malloc(sizeof(stackitem));
161			new_value= malloc(sizeof(value));
162			new_item->item=new_value;
163
164			/* The new value is a symbol */
165			new_value->type= symb;
166			new_value->refcount= 1;
167
168			/* Look up the symbol name in the hash table */
169			new_value->content.ptr= *hash(env->symbols, in_string);
170
171			if(new_value->content.ptr==NULL) { /* If symbol was undefined */
172
173			/* Create a new symbol */
174			new_symbol= malloc(sizeof(symbol));
175			new_symbol->val= NULL; /* undefined value */
176			new_symbol->next= NULL;
177			new_symbol->id= malloc(strlen(in_string)+1);
178			strcpy(new_symbol->id, in_string);
179	masse	1.1
180	teddy	1.28	/* Intern the new symbol in the hash table */
181			new_value->content.ptr= new_symbol;
182	masse	1.1
183	teddy	1.28	/* Try to load the symbol name as an external function, to see if
184			we should bind the symbol to a new function pointer value */
185	masse	1.16	if(handle==NULL) /* If no handle */
186	teddy	1.28	handle= dlopen(NULL, RTLD_LAZY);
187	masse	1.6
188	teddy	1.28	funcptr= dlsym(handle, in_string); /* Get function pointer */
189			if(dlerror()==NULL) { /* If a function was found */
190			new_fvalue= malloc(sizeof(value)); /* Create a new value */
191			new_fvalue->type=func; /* The new value is a function pointer */
192			new_fvalue->content.ptr=funcptr; /* Store function pointer */
193			new_symbol->val= new_fvalue; /* Bind the symbol to the new
194			function value */
195			new_fvalue->refcount= 1;
196			}
197	masse	1.1	}
198	teddy	1.28	push(&(env->head), new_item);
199	masse	1.1	return 1;
200			}
201
202	masse	1.17	void printerr(const char* in_string) {
203			fprintf(stderr, "Err: %s\n", in_string);
204			}
205
206	teddy	1.28	/* Throw away a value */
207			void free_val(value *val){
208			stackitem item, temp;
209
210			val->refcount--; /* Decrease the reference count */
211			if(val->refcount == 0){
212			switch (val->type){ /* and free the contents if necessary */
213			case string:
214			free(val->content.ptr);
215			case list: /* lists needs to be freed recursively */
216			item=val->content.ptr;
217			while(item != NULL) { /* for all stack items */
218			free_val(item->item); /* free the value */
219			temp=item->next; /* save next ptr */
220			free(item); /* free the stackitem */
221			item=temp; /* go to next stackitem */
222			}
223			free(val); /* Free the actual list value */
224			break;
225			default:
226			break;
227			}
228			}
229			}
230
231	masse	1.14	/* Discard the top element of the stack. */
232	teddy	1.28	extern void toss(environment *env)
233	masse	1.1	{
234	teddy	1.28	stackitem *temp= env->head;
235	masse	1.1
236	teddy	1.28	if((env->head)==NULL) {
237	masse	1.17	printerr("Stack empty");
238	masse	1.7	return;
239	masse	1.17	}
240	masse	1.7
241	teddy	1.28	free_val(env->head->item); /* Free the value */
242			env->head= env->head->next; /* Remove the top stack item */
243			free(temp); /* Free the old top stack item */
244	masse	1.1	}
245
246	masse	1.14	/* Print newline. */
247	masse	1.8	extern void nl()
248			{
249			printf("\n");
250			}
251	masse	1.1
252	masse	1.14	/* Prints the top element of the stack. */
253	teddy	1.28	void print_h(stackitem *stack_head)
254	masse	1.8	{
255	masse	1.23
256	teddy	1.28	if(stack_head==NULL) {
257	masse	1.17	printerr("Stack empty");
258	masse	1.8	return;
259	masse	1.17	}
260	masse	1.1
261	teddy	1.28	switch(stack_head->item->type) {
262			case integer:
263			printf("%d", stack_head->item->content.val);
264	teddy	1.2	break;
265			case string:
266	teddy	1.28	printf("\"%s\"", (char*)stack_head->item->content.ptr);
267	teddy	1.2	break;
268	teddy	1.28	case symb:
269			printf("'%s'", ((symbol *)(stack_head->item->content.ptr))->id);
270	masse	1.6	break;
271	masse	1.7	default:
272	teddy	1.28	printf("%p", (funcp)(stack_head->item->content.ptr));
273	teddy	1.2	break;
274			}
275	masse	1.1	}
276
277	teddy	1.28	extern void print_(environment *env) {
278			print_h(env->head);
279			}
280
281	masse	1.14	/* Prints the top element of the stack and then discards it. */
282	teddy	1.28	extern void print(environment *env)
283	masse	1.8	{
284	teddy	1.28	print_(env);
285			toss(env);
286	masse	1.8	}
287
288	masse	1.14	/* Only to be called by function printstack. */
289	teddy	1.28	void print_st(stackitem *stack_head, long counter)
290	masse	1.8	{
291			if(stack_head->next != NULL)
292			print_st(stack_head->next, counter+1);
293			printf("%ld: ", counter);
294	teddy	1.28	print_h(stack_head);
295	masse	1.8	nl();
296			}
297
298	teddy	1.28
299
300	masse	1.14	/* Prints the stack. */
301	teddy	1.28	extern void printstack(environment *env)
302	masse	1.1	{
303	teddy	1.28	if(env->head != NULL) {
304			print_st(env->head, 1);
305	masse	1.21	nl();
306	masse	1.17	} else {
307			printerr("Stack empty");
308	masse	1.1	}
309			}
310
311	masse	1.26	/* Swap the two top elements on the stack. */
312	teddy	1.28	extern void swap(environment *env)
313	masse	1.26	{
314	teddy	1.28	stackitem *temp= env->head;
315	masse	1.26
316	teddy	1.28	if((env->head)==NULL) {
317	masse	1.26	printerr("Stack empty");
318			return;
319			}
320
321	teddy	1.28	if(env->head->next==NULL) {
322			printerr("Not enough arguments");
323	masse	1.26	return;
324	teddy	1.28	}
325	masse	1.26
326	teddy	1.28	env->head= env->head->next;
327			temp->next= env->head->next;
328			env->head->next= temp;
329	masse	1.26	}
330
331			stackitem* copy(stackitem* in_item)
332			{
333	teddy	1.28	stackitem *out_item= malloc(sizeof(stackitem));
334	masse	1.26
335			memcpy(out_item, in_item, sizeof(stackitem));
336			out_item->next= NULL;
337
338			return out_item;
339			}
340
341
342	masse	1.14	/* If the top element is a reference, determine if it's a reference to a
343	masse	1.16	function, and if it is, toss the reference and execute the function. */
344	teddy	1.28	extern void eval(environment *env)
345	masse	1.1	{
346			funcp in_func;
347	teddy	1.28	stackitem* temp= env->head;
348	masse	1.1
349	masse	1.22	if(temp==NULL) {
350			printerr("Stack empty");
351	masse	1.1	return;
352	masse	1.17	}
353	masse	1.1
354	teddy	1.28	if(temp->item->type==symb
355			&& ((symbol *)(temp->item->content.ptr))->val != NULL
356			&& ((symbol *)(temp->item->content.ptr))->val->type == func) {
357			in_func= (funcp)(((symbol *)(temp->item->content.ptr))->val->content.ptr);
358			toss(env);
359			(*in_func)(env);
360			return;
361			}
362
363	masse	1.22
364	teddy	1.28	if(temp->item->type==func) {
365			in_func= (funcp)(temp->item->content.ptr);
366			toss(env);
367			(*in_func)(env);
368	masse	1.1	return;
369	masse	1.26	}
370
371	teddy	1.28	push(&(env->head), copy(temp));
372			swap(env);
373			toss(env);
374	masse	1.1	}
375
376	masse	1.19	/* Make a list. */
377	teddy	1.28	extern void pack(environment *env)
378	masse	1.19	{
379			void* delimiter;
380	teddy	1.28	stackitem iterator, temp;
381			value *pack;
382	masse	1.19
383	teddy	1.28	delimiter= env->head->item->content.ptr; /* Get delimiter */
384			toss(env);
385	masse	1.19
386	teddy	1.28	iterator= env->head;
387	masse	1.19
388	teddy	1.28	if(iterator==NULL \|\| iterator->item->content.ptr==delimiter) {
389	masse	1.24	temp= NULL;
390	teddy	1.28	toss(env);
391	masse	1.24	} else {
392			/* Search for first delimiter */
393	teddy	1.28	while(iterator->next!=NULL
394			&& iterator->next->item->content.ptr!=delimiter)
395	masse	1.24	iterator= iterator->next;
396
397			/* Extract list */
398	teddy	1.28	temp= env->head;
399			env->head= iterator->next;
400	masse	1.24	iterator->next= NULL;
401
402	teddy	1.28	if(env->head!=NULL)
403			toss(env);
404	masse	1.24	}
405	masse	1.19
406			/* Push list */
407	teddy	1.28	pack= malloc(sizeof(value));
408	masse	1.19	pack->type= list;
409			pack->content.ptr= temp;
410	teddy	1.28	pack->refcount= 1;
411
412			temp= malloc(sizeof(stackitem));
413			temp->item= pack;
414	masse	1.19
415	teddy	1.28	push(&(env->head), temp);
416	masse	1.19	}
417
418	masse	1.14	/* Parse input. */
419	teddy	1.28	int stack_read(environment env, char in_line)
420	masse	1.1	{
421			char temp, rest;
422			int itemp;
423			size_t inlength= strlen(in_line)+1;
424			int convert= 0;
425	masse	1.20	static int non_eval_flag= 0;
426	masse	1.1
427			temp= malloc(inlength);
428			rest= malloc(inlength);
429
430	masse	1.15	do {
431	masse	1.16	/* If string */
432	masse	1.15	if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
433	teddy	1.28	push_cstring(&(env->head), temp);
434	masse	1.15	break;
435			}
436	teddy	1.28	/* If integer */
437	masse	1.15	if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
438	teddy	1.28	push_val(&(env->head), itemp);
439	masse	1.15	break;
440			}
441	masse	1.16	/* Escape ';' with '\' */
442	masse	1.15	if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
443	teddy	1.28	temp[1]= '\0';
444			push_sym(env, temp);
445	masse	1.15	break;
446			}
447	masse	1.16	/* If symbol */
448	teddy	1.28	if((convert= sscanf(in_line, "%[^][ ;\n\r_]%[^\n\r]", temp, rest))) {
449			push_sym(env, temp);
450	masse	1.15	break;
451			}
452	masse	1.19	/* If single char */
453			if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
454			if(*temp==';') {
455	masse	1.21	if(!non_eval_flag) {
456	teddy	1.28	eval(env); /* Evaluate top element */
457	masse	1.20	break;
458			}
459
460	teddy	1.28	push_sym(env, ";");
461	masse	1.19	break;
462			}
463
464			if(*temp==']') {
465	teddy	1.28	push_sym(env, "[");
466			pack(env);
467	masse	1.21	if(non_eval_flag!=0)
468			non_eval_flag--;
469	masse	1.20	break;
470			}
471
472			if(*temp=='[') {
473	teddy	1.28	push_sym(env, "[");
474	masse	1.20	non_eval_flag++;
475	masse	1.19	break;
476			}
477	masse	1.15	}
478			} while(0);
479
480	masse	1.1
481			free(temp);
482
483			if(convert<2) {
484			free(rest);
485			return 0;
486			}
487
488	teddy	1.28	stack_read(env, rest);
489	masse	1.1
490			free(rest);
491			return 1;
492	masse	1.7	}
493	masse	1.1
494	masse	1.16	/* Relocate elements of the list on the stack. */
495	teddy	1.28	extern void expand(environment *env)
496	masse	1.1	{
497	masse	1.8	stackitem temp, new_head;
498
499	masse	1.16	/* Is top element a list? */
500	teddy	1.28	if(env->head==NULL \|\| env->head->item->type!=list) {
501	masse	1.17	printerr("Stack empty or not a list");
502	masse	1.8	return;
503	masse	1.17	}
504	masse	1.8
505	masse	1.16	/* The first list element is the new stack head */
506	teddy	1.28	new_head= temp= env->head->item->content.ptr;
507	masse	1.8
508	teddy	1.28	env->head->item->refcount++;
509			toss(env);
510	masse	1.24
511	teddy	1.28	/* Find the end of the list */
512	masse	1.8	while(temp->next!=NULL)
513			temp= temp->next;
514
515	teddy	1.28	/* Connect the tail of the list with the old stack head */
516			temp->next= env->head;
517			env->head= new_head; /* ...and voila! */
518
519	teddy	1.5	}
520	masse	1.11
521	masse	1.14	/* Compares two elements by reference. */
522	teddy	1.28	extern void eq(environment *env)
523	masse	1.11	{
524			void left, right;
525			int result;
526
527	teddy	1.28	if((env->head)==NULL \|\| env->head->next==NULL) {
528	masse	1.17	printerr("Not enough elements to compare");
529	masse	1.11	return;
530	masse	1.17	}
531	masse	1.11
532	teddy	1.28	left= env->head->item->content.ptr;
533			swap(env);
534			right= env->head->item->content.ptr;
535	masse	1.11	result= (left==right);
536
537	teddy	1.28	toss(env); toss(env);
538			push_val(&(env->head), result);
539	masse	1.11	}
540
541	masse	1.14	/* Negates the top element on the stack. */
542	teddy	1.28	extern void not(environment *env)
543	masse	1.11	{
544	teddy	1.28	int val;
545	masse	1.11
546	teddy	1.28	if((env->head)==NULL \|\| env->head->item->type!=integer) {
547			printerr("Stack empty or element is not a integer");
548	masse	1.11	return;
549	masse	1.17	}
550	masse	1.11
551	teddy	1.28	val= env->head->item->content.val;
552			toss(env);
553			push_val(&(env->head), !val);
554	masse	1.11	}
555
556	masse	1.14	/* Compares the two top elements on the stack and return 0 if they're the
557			same. */
558	teddy	1.28	extern void neq(environment *env)
559	masse	1.11	{
560	teddy	1.28	eq(env);
561			not(env);
562	masse	1.11	}
563	masse	1.12
564	masse	1.14	/* Give a symbol some content. */
565	teddy	1.28	extern void def(environment *env)
566	masse	1.12	{
567	teddy	1.28	symbol *sym;
568	masse	1.12
569	teddy	1.28	/* Needs two values on the stack, the top one must be a symbol */
570			if(env->head==NULL \|\| env->head->next==NULL
571			\|\| env->head->item->type!=symb) {
572	masse	1.17	printerr("Define what?");
573	masse	1.12	return;
574	masse	1.17	}
575	masse	1.12
576	teddy	1.28	/* long names are a pain */
577			sym=env->head->item->content.ptr;
578
579			/* if the symbol was bound to something else, throw it away */
580			if(sym->val != NULL)
581			free_val(sym->val);
582
583			/* Bind the symbol to the value */
584			sym->val= env->head->next->item;
585			sym->val->refcount++; /* Increase the reference counter */
586	masse	1.12
587	teddy	1.28	toss(env); toss(env);
588	masse	1.12	}
589	masse	1.10
590	masse	1.14	/* Quit stack. */
591	teddy	1.28	extern void quit(environment *env)
592	teddy	1.5	{
593			exit(EXIT_SUCCESS);
594	masse	1.24	}
595
596			/* Clear stack */
597	teddy	1.28	extern void clear(environment *env)
598	masse	1.24	{
599	teddy	1.28	while(env->head!=NULL)
600			toss(env);
601	masse	1.1	}
602
603			int main()
604			{
605	teddy	1.28	environment myenv;
606	masse	1.1	char in_string[100];
607
608	teddy	1.28	init_env(&myenv);
609	masse	1.1
610			printf("okidok\n ");
611
612			while(fgets(in_string, 100, stdin) != NULL) {
613	teddy	1.28	stack_read(&myenv, in_string);
614	masse	1.1	printf("okidok\n ");
615			}
616
617	masse	1.10	exit(EXIT_SUCCESS);
618	masse	1.1	}