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

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

  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	masse	1.16	func, /* Function pointer */
22	teddy	1.28	symb,
23	masse	1.16	list
24	teddy	1.18	} type; /* Type of stack element */
25
26	masse	1.1	union {
27	teddy	1.28	void ptr; / Pointer to the content */
28	masse	1.16	int val; /* ...or an integer */
29			} content; /* Stores a pointer or an integer */
30	masse	1.1
31	teddy	1.28	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	masse	1.1	} stackitem;
53
54	teddy	1.28	/* 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	teddy	1.33	int err; /* Error flag */
60	teddy	1.28	} 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	masse	1.1
66	teddy	1.28	/* Initialize a newly created environment */
67			void init_env(environment *env)
68	masse	1.1	{
69			long i;
70
71	teddy	1.35	env->err=0;
72	masse	1.1	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	teddy	1.35	void push(stackitem** stack_head, stackitem* in_item)
107	masse	1.1	{
108			in_item->next= *stack_head;
109			*stack_head= in_item;
110			}
111
112	teddy	1.29	/* 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	teddy	1.28	/* Push an integer onto the stack. */
122	teddy	1.35	void push_int(stackitem **stack_head, int in_val)
123	masse	1.1	{
124	teddy	1.28	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	masse	1.1
132			push(stack_head, new_item);
133			}
134
135	masse	1.14	/* Copy a string onto the stack. */
136	teddy	1.35	void push_cstring(stackitem *stack_head, const char in_string)
137	masse	1.1	{
138	teddy	1.28	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	masse	1.1
147			push(stack_head, new_item);
148			}
149
150	teddy	1.28	/* Push a symbol onto the stack. */
151	teddy	1.35	void push_sym(environment env, const char in_string)
152	masse	1.1	{
153	teddy	1.28	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	teddy	1.29	symbol *new_symbol; / (if needed) A new actual symbol */
158	teddy	1.28	/* ...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	teddy	1.29	new_symbol= hash(env->symbols, in_string);
176			new_value->content.ptr= *new_symbol;
177	teddy	1.28
178	teddy	1.30	if(new_symbol==NULL) { / If symbol was undefined */
179	teddy	1.28
180			/* Create a new symbol */
181	teddy	1.30	(*new_symbol)= malloc(sizeof(symbol));
182	teddy	1.29	(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	masse	1.1
187	teddy	1.28	/* Intern the new symbol in the hash table */
188	teddy	1.29	new_value->content.ptr= *new_symbol;
189	masse	1.1
190	teddy	1.28	/* 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	masse	1.16	if(handle==NULL) /* If no handle */
193	teddy	1.28	handle= dlopen(NULL, RTLD_LAZY);
194	masse	1.6
195	teddy	1.28	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	teddy	1.29	(new_symbol)->val= new_fvalue; / Bind the symbol to the new
201			function value */
202	teddy	1.28	new_fvalue->refcount= 1;
203			}
204	masse	1.1	}
205	teddy	1.28	push(&(env->head), new_item);
206	masse	1.1	}
207
208	masse	1.17	void printerr(const char* in_string) {
209			fprintf(stderr, "Err: %s\n", in_string);
210			}
211
212	teddy	1.28	/* 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	teddy	1.37	break;
222	teddy	1.28	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	masse	1.14	/* Discard the top element of the stack. */
239	teddy	1.28	extern void toss(environment *env)
240	masse	1.1	{
241	teddy	1.28	stackitem *temp= env->head;
242	masse	1.1
243	teddy	1.28	if((env->head)==NULL) {
244	teddy	1.36	printerr("Too Few Arguments");
245	teddy	1.35	env->err=1;
246	masse	1.7	return;
247	masse	1.17	}
248	masse	1.7
249	teddy	1.28	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	masse	1.1	}
253
254	masse	1.14	/* Print newline. */
255	masse	1.34	extern void nl()
256	masse	1.8	{
257			printf("\n");
258			}
259	masse	1.1
260	teddy	1.37	/* 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	masse	1.14	/* Prints the top element of the stack. */
294	teddy	1.28	void print_h(stackitem *stack_head)
295	masse	1.8	{
296	teddy	1.28	switch(stack_head->item->type) {
297			case integer:
298			printf("%d", stack_head->item->content.val);
299	teddy	1.2	break;
300			case string:
301	teddy	1.28	printf("\"%s\"", (char*)stack_head->item->content.ptr);
302	teddy	1.2	break;
303	teddy	1.28	case symb:
304			printf("'%s'", ((symbol *)(stack_head->item->content.ptr))->id);
305	masse	1.6	break;
306	teddy	1.35	case func:
307			printf("#<function %p>", (funcp)(stack_head->item->content.ptr));
308			break;
309			case list:
310			printf("#<list %p>", (funcp)(stack_head->item->content.ptr));
311			break;
312	masse	1.7	default:
313	teddy	1.35	printf("#<unknown %p>", (funcp)(stack_head->item->content.ptr));
314	teddy	1.2	break;
315			}
316	masse	1.1	}
317
318	teddy	1.28	extern void print_(environment *env) {
319	teddy	1.35	if(env->head==NULL) {
320	teddy	1.36	printerr("Too Few Arguments");
321	teddy	1.35	env->err=1;
322			return;
323			}
324	teddy	1.28	print_h(env->head);
325			}
326
327	masse	1.14	/* Prints the top element of the stack and then discards it. */
328	teddy	1.28	extern void print(environment *env)
329	masse	1.8	{
330	teddy	1.28	print_(env);
331	teddy	1.35	if(env->err) return;
332	teddy	1.28	toss(env);
333	masse	1.8	}
334
335	masse	1.14	/* Only to be called by function printstack. */
336	teddy	1.28	void print_st(stackitem *stack_head, long counter)
337	masse	1.8	{
338			if(stack_head->next != NULL)
339			print_st(stack_head->next, counter+1);
340			printf("%ld: ", counter);
341	teddy	1.28	print_h(stack_head);
342	masse	1.8	nl();
343			}
344
345	teddy	1.28
346
347	masse	1.14	/* Prints the stack. */
348	teddy	1.28	extern void printstack(environment *env)
349	masse	1.1	{
350	teddy	1.35	if(env->head == NULL) {
351			return;
352	masse	1.1	}
353	teddy	1.35	print_st(env->head, 1);
354			nl();
355	masse	1.1	}
356
357	masse	1.26	/* Swap the two top elements on the stack. */
358	teddy	1.28	extern void swap(environment *env)
359	masse	1.26	{
360	teddy	1.28	stackitem *temp= env->head;
361	masse	1.26
362	teddy	1.28	if((env->head)==NULL) {
363	teddy	1.36	printerr("Too Few Arguments");
364	teddy	1.35	env->err=1;
365	masse	1.26	return;
366			}
367
368	teddy	1.28	if(env->head->next==NULL) {
369	teddy	1.36	printerr("Too Few Arguments");
370	teddy	1.35	env->err=1;
371	masse	1.26	return;
372	teddy	1.28	}
373	masse	1.26
374	teddy	1.28	env->head= env->head->next;
375			temp->next= env->head->next;
376			env->head->next= temp;
377	masse	1.26	}
378
379			stackitem* copy(stackitem* in_item)
380			{
381	teddy	1.28	stackitem *out_item= malloc(sizeof(stackitem));
382	masse	1.26
383			memcpy(out_item, in_item, sizeof(stackitem));
384			out_item->next= NULL;
385
386			return out_item;
387			}
388
389	teddy	1.33	/* Recall a value from a symbol, if bound */
390	teddy	1.31	extern void rcl(environment *env)
391			{
392			value *val;
393
394			if(env->head == NULL) {
395	teddy	1.36	printerr("Too Few Arguments");
396	teddy	1.35	env->err=1;
397	teddy	1.31	return;
398			}
399
400			if(env->head->item->type!=symb) {
401	teddy	1.36	printerr("Bad Argument Type");
402			env->err=2;
403	teddy	1.31	return;
404			}
405	teddy	1.35
406	teddy	1.31	val=((symbol *)(env->head->item->content.ptr))->val;
407	teddy	1.33	if(val == NULL){
408	teddy	1.36	printerr("Unbound Variable");
409			env->err=3;
410	teddy	1.33	return;
411			}
412	teddy	1.31	toss(env); /* toss the symbol */
413	teddy	1.35	if(env->err) return;
414	teddy	1.31	push_val(&(env->head), val); /* Return its bound value */
415			}
416	masse	1.26
417	teddy	1.29	/* If the top element is a symbol, determine if it's bound to a
418			function value, and if it is, toss the symbol and execute the
419			function. */
420	teddy	1.28	extern void eval(environment *env)
421	masse	1.1	{
422			funcp in_func;
423	teddy	1.29	if(env->head==NULL) {
424	teddy	1.36	printerr("Too Few Arguments");
425	teddy	1.35	env->err=1;
426	masse	1.1	return;
427	masse	1.17	}
428	masse	1.1
429	teddy	1.29	/* if it's a symbol */
430			if(env->head->item->type==symb) {
431
432	teddy	1.35	rcl(env); /* get its contents */
433			if(env->err) return;
434			if(env->head->item->type!=symb){ /* don't recurse symbols */
435			eval(env); /* evaluate the value */
436	teddy	1.29	return;
437			}
438	teddy	1.28	}
439	masse	1.22
440	teddy	1.29	/* If it's a lone function value, run it */
441			if(env->head->item->type==func) {
442			in_func= (funcp)(env->head->item->content.ptr);
443	teddy	1.28	toss(env);
444	teddy	1.35	if(env->err) return;
445	teddy	1.28	(*in_func)(env);
446	masse	1.26	}
447	masse	1.1	}
448
449	masse	1.19	/* Make a list. */
450	teddy	1.28	extern void pack(environment *env)
451	masse	1.19	{
452			void* delimiter;
453	teddy	1.28	stackitem iterator, temp;
454			value *pack;
455	masse	1.19
456	teddy	1.28	delimiter= env->head->item->content.ptr; /* Get delimiter */
457			toss(env);
458	masse	1.19
459	teddy	1.28	iterator= env->head;
460	masse	1.19
461	teddy	1.28	if(iterator==NULL \|\| iterator->item->content.ptr==delimiter) {
462	masse	1.24	temp= NULL;
463	teddy	1.28	toss(env);
464	masse	1.24	} else {
465			/* Search for first delimiter */
466	teddy	1.28	while(iterator->next!=NULL
467			&& iterator->next->item->content.ptr!=delimiter)
468	masse	1.24	iterator= iterator->next;
469
470			/* Extract list */
471	teddy	1.28	temp= env->head;
472			env->head= iterator->next;
473	masse	1.24	iterator->next= NULL;
474
475	teddy	1.28	if(env->head!=NULL)
476			toss(env);
477	masse	1.24	}
478	masse	1.19
479			/* Push list */
480	teddy	1.28	pack= malloc(sizeof(value));
481	masse	1.19	pack->type= list;
482			pack->content.ptr= temp;
483	teddy	1.28	pack->refcount= 1;
484
485			temp= malloc(sizeof(stackitem));
486			temp->item= pack;
487	masse	1.19
488	teddy	1.28	push(&(env->head), temp);
489	masse	1.19	}
490
491	masse	1.14	/* Parse input. */
492	teddy	1.37	void stack_read(environment env, char in_line)
493	masse	1.1	{
494			char temp, rest;
495			int itemp;
496			size_t inlength= strlen(in_line)+1;
497			int convert= 0;
498	masse	1.20	static int non_eval_flag= 0;
499	masse	1.1
500			temp= malloc(inlength);
501			rest= malloc(inlength);
502
503	masse	1.15	do {
504	masse	1.16	/* If string */
505	masse	1.15	if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {
506	teddy	1.28	push_cstring(&(env->head), temp);
507	masse	1.15	break;
508			}
509	teddy	1.28	/* If integer */
510	masse	1.15	if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {
511	teddy	1.29	push_int(&(env->head), itemp);
512	masse	1.15	break;
513			}
514	masse	1.16	/* Escape ';' with '\' */
515	masse	1.15	if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {
516	teddy	1.28	temp[1]= '\0';
517			push_sym(env, temp);
518	masse	1.15	break;
519			}
520	masse	1.16	/* If symbol */
521	masse	1.34	if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {
522	teddy	1.28	push_sym(env, temp);
523	masse	1.15	break;
524			}
525	masse	1.19	/* If single char */
526			if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {
527			if(*temp==';') {
528	masse	1.21	if(!non_eval_flag) {
529	teddy	1.28	eval(env); /* Evaluate top element */
530	masse	1.20	break;
531			}
532
533	teddy	1.28	push_sym(env, ";");
534	masse	1.19	break;
535			}
536
537			if(*temp==']') {
538	teddy	1.28	push_sym(env, "[");
539			pack(env);
540	masse	1.21	if(non_eval_flag!=0)
541			non_eval_flag--;
542	masse	1.20	break;
543			}
544
545			if(*temp=='[') {
546	teddy	1.28	push_sym(env, "[");
547	masse	1.20	non_eval_flag++;
548	masse	1.19	break;
549			}
550	masse	1.15	}
551			} while(0);
552
553	masse	1.1	free(temp);
554
555			if(convert<2) {
556			free(rest);
557	teddy	1.37	return;
558	masse	1.1	}
559
560	teddy	1.28	stack_read(env, rest);
561	masse	1.1
562			free(rest);
563	masse	1.7	}
564	masse	1.1
565	masse	1.16	/* Relocate elements of the list on the stack. */
566	teddy	1.28	extern void expand(environment *env)
567	masse	1.1	{
568	masse	1.8	stackitem temp, new_head;
569
570	masse	1.16	/* Is top element a list? */
571	teddy	1.36	if(env->head==NULL) {
572			printerr("Too Few Arguments");
573	teddy	1.35	env->err=1;
574	masse	1.8	return;
575	masse	1.17	}
576	teddy	1.36	if(env->head->item->type!=list) {
577			printerr("Bad Argument Type");
578			env->err=2;
579			return;
580			}
581	masse	1.8
582	masse	1.16	/* The first list element is the new stack head */
583	teddy	1.28	new_head= temp= env->head->item->content.ptr;
584	masse	1.8
585	teddy	1.28	env->head->item->refcount++;
586			toss(env);
587	masse	1.24
588	teddy	1.28	/* Find the end of the list */
589	masse	1.8	while(temp->next!=NULL)
590			temp= temp->next;
591
592	teddy	1.28	/* Connect the tail of the list with the old stack head */
593			temp->next= env->head;
594			env->head= new_head; /* ...and voila! */
595
596	teddy	1.5	}
597	masse	1.11
598	masse	1.14	/* Compares two elements by reference. */
599	teddy	1.28	extern void eq(environment *env)
600	masse	1.11	{
601			void left, right;
602			int result;
603
604	teddy	1.28	if((env->head)==NULL \|\| env->head->next==NULL) {
605	teddy	1.36	printerr("Too Few Arguments");
606	teddy	1.35	env->err=1;
607	masse	1.11	return;
608	masse	1.17	}
609	masse	1.11
610	teddy	1.28	left= env->head->item->content.ptr;
611			swap(env);
612			right= env->head->item->content.ptr;
613	masse	1.11	result= (left==right);
614
615	teddy	1.28	toss(env); toss(env);
616	teddy	1.29	push_int(&(env->head), result);
617	masse	1.11	}
618
619	masse	1.14	/* Negates the top element on the stack. */
620	teddy	1.28	extern void not(environment *env)
621	masse	1.11	{
622	teddy	1.28	int val;
623	masse	1.11
624	teddy	1.36	if((env->head)==NULL) {
625			printerr("Too Few Arguments");
626	teddy	1.35	env->err=1;
627	masse	1.11	return;
628	masse	1.17	}
629	masse	1.11
630	teddy	1.36	if(env->head->item->type!=integer) {
631			printerr("Bad Argument Type");
632			env->err=2;
633			return;
634			}
635
636	teddy	1.28	val= env->head->item->content.val;
637			toss(env);
638	teddy	1.29	push_int(&(env->head), !val);
639	masse	1.11	}
640
641	masse	1.14	/* Compares the two top elements on the stack and return 0 if they're the
642			same. */
643	teddy	1.28	extern void neq(environment *env)
644	masse	1.11	{
645	teddy	1.28	eq(env);
646			not(env);
647	masse	1.11	}
648	masse	1.12
649	masse	1.14	/* Give a symbol some content. */
650	teddy	1.28	extern void def(environment *env)
651	masse	1.12	{
652	teddy	1.28	symbol *sym;
653	masse	1.12
654	teddy	1.28	/* Needs two values on the stack, the top one must be a symbol */
655	teddy	1.36	if(env->head==NULL \|\| env->head->next==NULL) {
656			printerr("Too Few Arguments");
657	teddy	1.35	env->err=1;
658	masse	1.12	return;
659	masse	1.17	}
660	masse	1.12
661	teddy	1.36	if(env->head->item->type!=symb) {
662			printerr("Bad Argument Type");
663			env->err=2;
664			return;
665			}
666
667	teddy	1.28	/* long names are a pain */
668			sym=env->head->item->content.ptr;
669
670			/* if the symbol was bound to something else, throw it away */
671			if(sym->val != NULL)
672			free_val(sym->val);
673
674			/* Bind the symbol to the value */
675			sym->val= env->head->next->item;
676			sym->val->refcount++; /* Increase the reference counter */
677	masse	1.12
678	teddy	1.28	toss(env); toss(env);
679	masse	1.12	}
680	masse	1.10
681	masse	1.14	/* Quit stack. */
682	teddy	1.28	extern void quit(environment *env)
683	teddy	1.5	{
684			exit(EXIT_SUCCESS);
685	masse	1.24	}
686
687			/* Clear stack */
688	teddy	1.28	extern void clear(environment *env)
689	masse	1.24	{
690	teddy	1.28	while(env->head!=NULL)
691			toss(env);
692	masse	1.1	}
693
694	teddy	1.33	/* List all defined words */
695	masse	1.32	extern void words(environment *env)
696			{
697			symbol *temp;
698			int i;
699
700			for(i= 0; i<HASHTBLSIZE; i++) {
701			temp= env->symbols[i];
702			while(temp!=NULL) {
703			printf("%s\n", temp->id);
704			temp= temp->next;
705			}
706			}
707			}
708	masse	1.34
709			/* Forgets a symbol (remove it from the hash table) */
710			extern void forget(environment *env)
711			{
712			char* sym_id;
713			stackitem *stack_head= env->head;
714			symbol *hash_entry, temp;
715
716	teddy	1.36	if(stack_head==NULL) {
717			printerr("Too Few Arguments");
718			env->err=1;
719			return;
720			}
721
722			if(stack_head->item->type!=symb) {
723			printerr("Bad Argument Type");
724			env->err=2;
725	masse	1.34	return;
726			}
727
728			sym_id= ((symbol*)(stack_head->item->content.ptr))->id;
729			toss(env);
730
731			hash_entry= hash(env->symbols, sym_id);
732			temp= *hash_entry;
733			hash_entry= (hash_entry)->next;
734
735			if(temp->val!=NULL) {
736			free_val(temp->val);
737			}
738			free(temp->id);
739			free(temp);
740	teddy	1.36	}
741
742			/* Returns the current error number to the stack */
743			extern void errn(environment *env){
744			push_int(&(env->head), env->err);
745			}
746	masse	1.32
747	masse	1.1	int main()
748			{
749	teddy	1.28	environment myenv;
750	masse	1.1	char in_string[100];
751
752	teddy	1.28	init_env(&myenv);
753	masse	1.1
754			printf("okidok\n ");
755
756			while(fgets(in_string, 100, stdin) != NULL) {
757	teddy	1.28	stack_read(&myenv, in_string);
758	teddy	1.35	if(myenv.err) {
759			printf("(error %d) ", myenv.err);
760			myenv.err=0;
761			}
762	masse	1.1	printf("okidok\n ");
763			}
764
765	masse	1.10	exit(EXIT_SUCCESS);
766	masse	1.1	}