--- stack/stack.c	2002/03/17 00:55:58	1.113
+++ stack/stack.c	2002/03/27 14:45:17	1.121
@@ -1,3 +1,4 @@
+/* -*- coding: utf-8; -*- */
 /*
     stack - an interactive interpreter for a stack-based language
     Copyright (C) 2002	Mats Alritzson and Teddy Hogeborn
@@ -20,8 +21,8 @@
 	     Teddy Hogeborn <teddy@fukt.bth.se>
 */
 
-#define CAR(X) (X->content.c->car)
-#define CDR(X) (X->content.c->cdr)
+#define CAR(X) ((X)->content.c->car)
+#define CDR(X) ((X)->content.c->cdr)
 
 /* printf, sscanf, fgets, fprintf, fopen, perror */
 #include <stdio.h>
@@ -61,7 +62,6 @@
   env->gc_ref= NULL;
 
   env->head= new_val(env);
-  env->head->type= empty;
   for(i= 0; i<HASHTBLSIZE; i++)
     env->symbols[i]= NULL;
   env->err= 0;
@@ -123,8 +123,11 @@
   value *nval= malloc(sizeof(value));
   stackitem *nitem= malloc(sizeof(stackitem));
 
+  assert(nval != NULL);
+  assert(nitem != NULL);
+
   nval->content.ptr= NULL;
-  nval->type= integer;
+  nval->type= empty;
 
   nitem->item= nval;
   nitem->next= env->gc_ref;
@@ -165,7 +168,6 @@
 extern void gc_init(environment *env)
 {
   stackitem *new_head= NULL, *titem;
-  cons *iterator;
   symbol *tsymb;
   int i;
 
@@ -195,8 +197,21 @@
 
     if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
 
-      if(env->gc_ref->item->type==string) /* Remove content */
+      /* Remove content */
+      switch(env->gc_ref->item->type){
+      case string:
 	free(env->gc_ref->item->content.ptr);
+	break;
+      case tcons:
+	free(env->gc_ref->item->content.c);
+	break;
+      case empty:
+      case integer:
+      case tfloat:
+      case func:
+      case symb:
+	/* Symbol strings are freed when walking the hash table */
+      }
 
       free(env->gc_ref->item);	/* Remove from gc_ref */
       titem= env->gc_ref->next;
@@ -233,7 +248,7 @@
     /* Keep values */     
     env->gc_count += sizeof(value);
     if(env->gc_ref->item->type==string)
-      env->gc_count += strlen(env->gc_ref->item->content.ptr);
+      env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
     
     titem= env->gc_ref->next;
     env->gc_ref->next= new_head;
@@ -285,8 +300,9 @@
 {
   value *new_value= new_val(env);
 
-  new_value->content.c= malloc(sizeof(cons));
+  new_value->content.c= malloc(sizeof(pair));
   assert(new_value->content.c!=NULL);
+  env->gc_count += sizeof(pair);
   new_value->type= tcons;
   CAR(new_value)= val;
   CDR(new_value)= env->head;
@@ -322,6 +338,7 @@
   int length= strlen(in_string)+1;
 
   new_value->content.ptr= malloc(length);
+  assert(new_value != NULL);
   env->gc_count += length;
   strcpy(new_value->content.ptr, in_string);
   new_value->type= string;
@@ -336,6 +353,7 @@
   char *new_string, *current;
 
   new_string= malloc((strlen(old_string)*2)+4);
+  assert(new_string != NULL);
   strcpy(new_string, "sx_");	/* Stack eXternal */
   current= new_string+3;
   while(old_string[0] != '\0'){
@@ -405,9 +423,11 @@
 
     /* Create a new symbol */
     (*new_symbol)= malloc(sizeof(symbol));
+    assert((*new_symbol) != NULL);
     (*new_symbol)->val= NULL;	/* undefined value */
     (*new_symbol)->next= NULL;
     (*new_symbol)->id= malloc(strlen(in_string)+1);
+    assert((*new_symbol)->id != NULL);
     strcpy((*new_symbol)->id, in_string);
 
     /* Intern the new symbol in the hash table */
@@ -484,9 +504,12 @@
   toss(env);
 }    
 
-/* Prints the top element of the stack. */
-void print_val(value *val, int noquote)
+/* Print a value */
+void print_val(value *val, int noquote, stackitem *stack)
 {
+  stackitem *titem, *tstack;
+  int depth;
+
   switch(val->type) {
   case empty:
     printf("[]");
@@ -511,20 +534,56 @@
     break;
   case tcons:
     printf("[ ");
+    tstack= stack;
     do {
-      print_val(CAR(val), noquote);
-      switch(CDR(val)->type){
+      titem=malloc(sizeof(stackitem));
+      assert(titem != NULL);
+      titem->item=val;
+      titem->next=tstack;
+      tstack=titem;		/* Put it on the stack */
+      /* Search a stack of values being printed to see if we are already
+	 printing this value */
+      titem=tstack;
+      depth=0;
+      while(titem != NULL && titem->item != CAR(val)){
+	titem=titem->next;
+	depth++;
+      }
+      if(titem != NULL){	/* If we found it on the stack, */
+	printf("#%d#", depth);	/* print a depth reference */
+      } else {
+	print_val(CAR(val), noquote, tstack);
+      }
+      val= CDR(val);
+      switch(val->type){
       case empty:
 	break;
       case tcons:
-	printf(" ");
+	/* Search a stack of values being printed to see if we are already
+	   printing this value */
+	titem=tstack;
+	depth=0;
+	while(titem != NULL && titem->item != val){
+	  titem=titem->next;
+	  depth++;
+	}
+	if(titem != NULL){	/* If we found it on the stack, */
+	  printf(" . #%d#", depth); /* print a depth reference */
+	} else {
+	  printf(" ");
+	}
 	break;
       default:
 	printf(" . ");		/* Improper list */
-	print_val(CDR(val), noquote);
+	print_val(val, noquote, tstack);
       }
-      val= CDR(val);
-    } while(val->type == tcons);
+    } while(val->type == tcons && titem == NULL);
+    titem=tstack;
+    while(titem != stack){
+      tstack=titem->next;
+      free(titem);
+      titem=tstack;
+    }
     printf(" ]");
     break;
   }
@@ -537,7 +596,7 @@
     env->err= 1;
     return;
   }
-  print_val(CAR(env->head), 0);
+  print_val(CAR(env->head), 0, NULL);
   nl();
 }
 
@@ -556,7 +615,7 @@
     env->err= 1;
     return;
   }
-  print_val(CAR(env->head), 1);
+  print_val(CAR(env->head), 1, NULL);
 }
 
 /* Prints the top element of the stack and then discards it. */
@@ -573,7 +632,7 @@
   if(CDR(stack_head)->type != empty)
     print_st(CDR(stack_head), counter+1);
   printf("%ld: ", counter);
-  print_val(CAR(stack_head), 0);
+  print_val(CAR(stack_head), 0, NULL);
   nl();
 }
 
@@ -720,7 +779,10 @@
     unprotect(temp_val);
     return;
 
-  default:
+  case empty:
+  case integer:
+  case tfloat:
+  case string:
     return;
   }
 }
@@ -747,7 +809,6 @@
 
   old_head= CAR(env->head);
   new_head= new_val(env);
-  new_head->type= empty;
   while(old_head->type != empty) {
     item= old_head;
     old_head= CDR(old_head);
@@ -763,7 +824,6 @@
   value *iterator, *temp, *ending;
 
   ending=new_val(env);
-  ending->type=empty;
 
   iterator= env->head;
   if(iterator->type == empty
@@ -1049,7 +1109,7 @@
   }
 
   if(myenv.interactive) {
-    printf("Stack version $Revision: 1.113 $\n\
+    printf("Stack version $Revision: 1.121 $\n\
 Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
 Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
 This is free software, and you are welcome to redistribute it\n\
@@ -1109,6 +1169,7 @@
     toss(env); if(env->err) return;
     len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
     new_string= malloc(len);
+    assert(new_string != NULL);
     strcpy(new_string, b_val->content.ptr);
     strcat(new_string, a_val->content.ptr);
     push_cstring(env, new_string);
@@ -1324,6 +1385,7 @@
   case integer:
   case func:
   case symb:
+  case empty:
     new_value->content= old_value->content;
     break;
   case string:
@@ -1332,8 +1394,9 @@
     break;
   case tcons:
 
-    new_value->content.c= malloc(sizeof(cons));
+    new_value->content.c= malloc(sizeof(pair));
     assert(new_value->content.c!=NULL);
+    env->gc_count += sizeof(pair);
 
     CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
     CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
@@ -1607,7 +1670,9 @@
 extern void to(environment *env)
 {
   int ending, start, i;
-  value *iterator, *temp;
+  value *iterator, *temp, *end;
+
+  end= new_val(env);
 
   if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
@@ -1642,11 +1707,11 @@
   if(iterator->type==empty
      || (CAR(iterator)->type==symb
 	 && CAR(iterator)->content.sym->id[0]=='[')) {
-    temp= NULL;
+    temp= end;
     toss(env);
   } else {
     /* Search for first delimiter */
-    while(CDR(iterator)!=NULL 
+    while(CDR(iterator)->type!=empty 
 	  && (CAR(CDR(iterator))->type!=symb
 	      || CAR(CDR(iterator))->content.sym->id[0]!='['))
       iterator= CDR(iterator);
@@ -1654,9 +1719,9 @@
     /* Extract list */
     temp= env->head;
     env->head= CDR(iterator);
-    CDR(iterator)= NULL;
+    CDR(iterator)= end;
 
-    if(env->head!=NULL)
+    if(env->head->type!=empty)
       toss(env);
   }
 
@@ -1691,7 +1756,7 @@
   int count= -1;
   float ftemp;
   static int depth= 0;
-  char *match, *ctemp;
+  char *match;
   size_t inlength;
 
   if(env->in_string==NULL) {
@@ -1706,6 +1771,7 @@
     }
     
     env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
+    assert(env->in_string != NULL);
     env->free_string= env->in_string; /* Save the original pointer */
     strcpy(env->in_string, CAR(env->head)->content.ptr);
     toss(env); if(env->err) return;
@@ -1713,6 +1779,7 @@
   
   inlength= strlen(env->in_string)+1;
   match= malloc(inlength);
+  assert(match != NULL);
 
   if(sscanf(env->in_string, blankform, &readlength) != EOF
      && readlength != -1) {
@@ -1725,6 +1792,9 @@
     } else {
       push_float(env, ftemp);
     }
+  } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
+	    && readlength != -1) {
+    push_cstring(env, "");
   } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
 	    && readlength != -1) {
     push_cstring(env, match);
@@ -2350,3 +2420,109 @@
 
   CAR(env->head)=CDR(CAR(env->head));
 }
+
+extern void cons(environment *env)
+{
+  value *val;
+
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  val=new_val(env);
+  val->content.c= malloc(sizeof(pair));
+  assert(val->content.c!=NULL);
+
+  env->gc_count += sizeof(pair);
+  val->type=tcons;
+
+  CAR(val)= CAR(CDR(env->head));
+  CDR(val)= CAR(env->head);
+
+  push_val(env, val);
+
+  swap(env); if(env->err) return;
+  toss(env); if(env->err) return;
+  swap(env); if(env->err) return;
+  toss(env); if(env->err) return;
+}
+
+/*  2: 3                        =>                */
+/*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
+extern void assq(environment *env)
+{
+  assocgen(env, eq);
+}
+
+
+/* General assoc function */
+void assocgen(environment *env, funcp eqfunc)
+{
+  value *key, *item;
+
+  /* Needs two values on the stack, the top one must be an association
+     list */
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=tcons) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  key=CAR(CDR(env->head));
+  item=CAR(env->head);
+
+  while(item->type == tcons){
+    if(CAR(item)->type != tcons){
+      printerr("Bad Argument Type");
+      env->err= 2;
+      return;
+    }
+    push_val(env, key);
+    push_val(env, CAR(CAR(item)));
+    eqfunc(env); if(env->err) return;
+
+    /* Check the result of 'eqfunc' */
+    if(env->head->type==empty) {
+      printerr("Too Few Arguments");
+      env->err= 1;
+    return;
+    }
+    if(CAR(env->head)->type!=integer) {
+      printerr("Bad Argument Type");
+      env->err= 2;
+      return;
+    }
+
+    if(CAR(env->head)->content.i){
+      toss(env); if(env->err) return;
+      break;
+    }
+    toss(env); if(env->err) return;
+
+    if(item->type!=tcons) {
+      printerr("Bad Argument Type");
+      env->err= 2;
+      return;
+    }
+
+    item=CDR(item);
+  }
+
+  if(item->type == tcons){	/* A match was found */
+    push_val(env, CAR(item));
+  } else {
+    push_int(env, 0);
+  }
+  swap(env); if(env->err) return;
+  toss(env); if(env->err) return;
+  swap(env); if(env->err) return;
+  toss(env);
+}