--- stack/stack.c	2002/03/16 19:09:54	1.111
+++ stack/stack.c	2002/03/17 12:49:27	1.116
@@ -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>
@@ -165,7 +166,6 @@
 extern void gc_init(environment *env)
 {
   stackitem *new_head= NULL, *titem;
-  cons *iterator;
   symbol *tsymb;
   int i;
 
@@ -195,8 +195,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 +246,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 +298,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;
@@ -450,17 +464,16 @@
 /* Gets the type of a value */
 extern void type(environment *env)
 {
-  int typenum;
-
   if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
   }
 
-  typenum= CAR(env->head)->type;
-  toss(env);
-  switch(typenum){
+  switch(CAR(env->head)->type){
+  case empty:
+    push_sym(env, "empty");
+    break;
   case integer:
     push_sym(env, "integer");
     break;
@@ -477,45 +490,55 @@
     push_sym(env, "function");
     break;
   case tcons:
-    push_sym(env, "list");
+    push_sym(env, "pair");
     break;
   }
+  swap(env);
+  if (env->err) return;
+  toss(env);
 }    
 
-/* Prints the top element of the stack. */
-void print_h(value *stack_head, int noquote)
+/* Print a value */
+void print_val(value *val, int noquote)
 {
-  switch(CAR(stack_head)->type) {
+  switch(val->type) {
+  case empty:
+    printf("[]");
+    break;
   case integer:
-    printf("%d", CAR(stack_head)->content.i);
+    printf("%d", val->content.i);
     break;
   case tfloat:
-    printf("%f", CAR(stack_head)->content.f);
+    printf("%f", val->content.f);
     break;
   case string:
     if(noquote)
-      printf("%s", (char*)CAR(stack_head)->content.ptr);
+      printf("%s", (char*)(val->content.ptr));
     else
-      printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
+      printf("\"%s\"", (char*)(val->content.ptr));
     break;
   case symb:
-    printf("%s", CAR(stack_head)->content.sym->id);
+    printf("%s", val->content.sym->id);
     break;
   case func:
-    printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
+    printf("#<function %p>", (funcp)(val->content.ptr));
     break;
   case tcons:
-    /* A list is just a stack, so make stack_head point to it */
-    stack_head= CAR(stack_head);
     printf("[ ");
-    while(CAR(stack_head)->type != empty) {
-      print_h(stack_head, noquote);
-      if(CDR(stack_head)->type==tcons)
+    do {
+      print_val(CAR(val), noquote);
+      val= CDR(val);
+      switch(val->type){
+      case empty:
+	break;
+      case tcons:
 	printf(" ");
-      else
+	break;
+      default:
 	printf(" . ");		/* Improper list */
-      stack_head= CDR(stack_head);
-    }
+	print_val(val, noquote);
+      }
+    } while(val->type == tcons);
     printf(" ]");
     break;
   }
@@ -528,7 +551,7 @@
     env->err= 1;
     return;
   }
-  print_h(env->head, 0);
+  print_val(CAR(env->head), 0);
   nl();
 }
 
@@ -547,7 +570,7 @@
     env->err= 1;
     return;
   }
-  print_h(env->head, 1);
+  print_val(CAR(env->head), 1);
 }
 
 /* Prints the top element of the stack and then discards it. */
@@ -564,7 +587,7 @@
   if(CDR(stack_head)->type != empty)
     print_st(CDR(stack_head), counter+1);
   printf("%ld: ", counter);
-  print_h(stack_head, 0);
+  print_val(CAR(stack_head), 0);
   nl();
 }
 
@@ -711,7 +734,10 @@
     unprotect(temp_val);
     return;
 
-  default:
+  case empty:
+  case integer:
+  case tfloat:
+  case string:
     return;
   }
 }
@@ -1040,7 +1066,7 @@
   }
 
   if(myenv.interactive) {
-    printf("Stack version $Revision: 1.111 $\n\
+    printf("Stack version $Revision: 1.116 $\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\
@@ -1315,6 +1341,7 @@
   case integer:
   case func:
   case symb:
+  case empty:
     new_value->content= old_value->content;
     break;
   case string:
@@ -1323,8 +1350,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 */
@@ -1682,7 +1710,7 @@
   int count= -1;
   float ftemp;
   static int depth= 0;
-  char *match, *ctemp;
+  char *match;
   size_t inlength;
 
   if(env->in_string==NULL) {
@@ -1716,6 +1744,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);
@@ -2271,3 +2302,101 @@
   printerr("Bad Argument Type");
   env->err= 2;
 }
+
+extern void setcar(environment *env)
+{
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CDR(env->head)->type!=tcons) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  CAR(CAR(CDR(env->head)))=CAR(env->head);
+  toss(env);
+}
+
+extern void setcdr(environment *env)
+{
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CDR(env->head)->type!=tcons) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  CDR(CAR(CDR(env->head)))=CAR(env->head);
+  toss(env);
+}
+
+extern void car(environment *env)
+{
+  if(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;
+  }
+
+  CAR(env->head)=CAR(CAR(env->head));
+}
+
+extern void cdr(environment *env)
+{
+  if(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;
+  }
+
+  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;
+}