--- stack/stack.c	2002/03/12 22:03:21	1.108
+++ 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>
@@ -60,7 +61,8 @@
   env->gc_count= 0;
   env->gc_ref= NULL;
 
-  env->head= NULL;
+  env->head= new_val(env);
+  env->head->type= empty;
   for(i= 0; i<HASHTBLSIZE; i++)
     env->symbols[i]= NULL;
   env->err= 0;
@@ -78,7 +80,7 @@
 /* Discard the top element of the stack. */
 extern void toss(environment *env)
 {
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -164,7 +166,6 @@
 extern void gc_init(environment *env)
 {
   stackitem *new_head= NULL, *titem;
-  cons *iterator;
   symbol *tsymb;
   int i;
 
@@ -188,27 +189,64 @@
   if(env->interactive)
     printf(".");
 
-
   env->gc_count= 0;
 
   while(env->gc_ref!=NULL) {	/* Sweep unused values */
 
     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;
       free(env->gc_ref);	/* Remove value */
       env->gc_ref= titem;
       continue;
-    } 
+    }
+#ifdef DEBUG
+    printf("Kept value (%p)", env->gc_ref->item);
+    if(env->gc_ref->item->gc.flag.mark)
+      printf(" (marked)");
+    if(env->gc_ref->item->gc.flag.protect)
+      printf(" (protected)");
+    switch(env->gc_ref->item->type){
+    case integer:
+      printf(" integer: %d", env->gc_ref->item->content.i);
+      break;
+    case func:
+      printf(" func: %p", env->gc_ref->item->content.ptr);
+      break;
+    case symb:
+      printf(" symb: %s", env->gc_ref->item->content.sym->id);
+      break;
+    case tcons:
+      printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
+	     env->gc_ref->item->content.c->cdr);
+      break;
+    default:
+      printf(" <unknown %d>", (env->gc_ref->item->type));
+    }
+    printf("\n");
+#endif /* DEBUG */
 
     /* 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;
@@ -223,7 +261,7 @@
   env->gc_ref= new_head;
 
   if(env->interactive)
-    printf("done\n");
+    printf("done (%d bytes still allocated)\n", env->gc_count);
 
 }
 
@@ -260,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;
@@ -328,7 +367,7 @@
 {
   char *new_string;
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -425,17 +464,16 @@
 /* Gets the type of a value */
 extern void type(environment *env)
 {
-  int typenum;
-
-  if(env->head==NULL) {
+  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;
@@ -452,55 +490,68 @@
     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(stack_head != NULL) {
-      print_h(stack_head, noquote);
-      printf(" ");
-      stack_head= CDR(stack_head);
-    }
-    printf("]");
+    do {
+      print_val(CAR(val), noquote);
+      val= CDR(val);
+      switch(val->type){
+      case empty:
+	break;
+      case tcons:
+	printf(" ");
+	break;
+      default:
+	printf(" . ");		/* Improper list */
+	print_val(val, noquote);
+      }
+    } while(val->type == tcons);
+    printf(" ]");
     break;
   }
 }
 
 extern void print_(environment *env)
 {
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
   }
-  print_h(env->head, 0);
+  print_val(CAR(env->head), 0);
   nl();
 }
 
@@ -514,12 +565,12 @@
 
 extern void princ_(environment *env)
 {
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     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. */
@@ -533,17 +584,17 @@
 /* Only to be called by function printstack. */
 void print_st(value *stack_head, long counter)
 { 
-  if(CDR(stack_head) != NULL)
+  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();
 }
 
 /* Prints the stack. */
 extern void printstack(environment *env)
 {
-  if(env->head == NULL) {
+  if(env->head->type == empty) {
     printf("Stack Empty\n");
     return;
   }
@@ -556,7 +607,7 @@
 {
   value *temp= env->head;
   
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type == empty || CDR(env->head)->type == empty) {
     printerr("Too Few Arguments");
     env->err=1;
     return;
@@ -572,8 +623,8 @@
 {
   value *temp= env->head;
   
-  if(env->head==NULL || CDR(env->head)==NULL
-     || CDR(CDR(env->head))==NULL) {
+  if(env->head->type == empty || CDR(env->head)->type == empty
+     || CDR(CDR(env->head))->type == empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -589,7 +640,7 @@
 {
   value *val;
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -607,11 +658,11 @@
     env->err= 3;
     return;
   }
-  protect(val);
-  toss(env);		/* toss the symbol */
+  push_val(env, val);		/* Return the symbol's bound value */
+  swap(env);
+  if(env->err) return;
+  toss(env);			/* toss the symbol */
   if(env->err) return;
-  push_val(env, val); /* Return its bound value */
-  unprotect(val);
 }
 
 /* If the top element is a symbol, determine if it's bound to a
@@ -627,7 +678,7 @@
 
   gc_maybe(env);
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -658,7 +709,7 @@
     toss(env); if(env->err) return;
     iterator= temp_val;
     
-    while(iterator!=NULL) {
+    while(iterator->type != empty) {
       push_val(env, CAR(iterator));
       
       if(CAR(env->head)->type==symb
@@ -666,13 +717,13 @@
 	toss(env);
 	if(env->err) return;
 	
-	if(CDR(iterator)==NULL){
+	if(CDR(iterator)->type == empty){
 	  goto eval_start;
 	}
 	eval(env);
 	if(env->err) return;
       }
-      if (CDR(iterator)->type == tcons) 
+      if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons) 
 	iterator= CDR(iterator);
       else {
 	printerr("Bad Argument Type"); /* Improper list */
@@ -683,7 +734,10 @@
     unprotect(temp_val);
     return;
 
-  default:
+  case empty:
+  case integer:
+  case tfloat:
+  case string:
     return;
   }
 }
@@ -693,12 +747,15 @@
 {
   value *old_head, *new_head, *item;
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
   }
 
+  if(CAR(env->head)->type==empty)
+    return;			/* Don't reverse an empty list */
+
   if(CAR(env->head)->type!=tcons) {
     printerr("Bad Argument Type");
     env->err= 2;
@@ -706,8 +763,9 @@
   }
 
   old_head= CAR(env->head);
-  new_head= NULL;
-  while(old_head!=NULL) {
+  new_head= new_val(env);
+  new_head->type= empty;
+  while(old_head->type != empty) {
     item= old_head;
     old_head= CDR(old_head);
     CDR(item)= new_head;
@@ -719,17 +777,20 @@
 /* Make a list. */
 extern void pack(environment *env)
 {
-  value *iterator, *temp;
+  value *iterator, *temp, *ending;
+
+  ending=new_val(env);
+  ending->type=empty;
 
   iterator= env->head;
-  if(iterator==NULL
+  if(iterator->type == empty
      || (CAR(iterator)->type==symb
      && CAR(iterator)->content.sym->id[0]=='[')) {
-    temp= NULL;
+    temp= ending;
     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);
@@ -737,9 +798,9 @@
     /* Extract list */
     temp= env->head;
     env->head= CDR(iterator);
-    CDR(iterator)= NULL;
+    CDR(iterator)= ending;
 
-    if(env->head!=NULL)
+    if(env->head->type != empty)
       toss(env);
   }
 
@@ -755,7 +816,7 @@
   value *temp, *new_head;
 
   /* Is top element a list? */
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -778,7 +839,7 @@
   toss(env);
 
   /* Find the end of the list */
-  while(CDR(temp)->content.ptr != NULL) {
+  while(CDR(temp)->type != empty) {
     if (CDR(temp)->type == tcons)
       temp= CDR(temp);
     else {
@@ -799,7 +860,7 @@
 {
   void *left, *right;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -817,7 +878,7 @@
 {
   int val;
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -848,7 +909,7 @@
   symbol *sym;
 
   /* Needs two values on the stack, the top one must be a symbol */
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -887,6 +948,8 @@
   env->gc_limit= 0;
   gc_maybe(env);
 
+  words(env);
+
   if(env->free_string!=NULL)
     free(env->free_string);
   
@@ -900,7 +963,7 @@
 /* Clear stack */
 extern void clear(environment *env)
 {
-  while(env->head!=NULL)
+  while(env->head->type != empty)
     toss(env);
 }
 
@@ -913,6 +976,10 @@
   for(i= 0; i<HASHTBLSIZE; i++) {
     temp= env->symbols[i];
     while(temp!=NULL) {
+#ifdef DEBUG
+      if (temp->val != NULL && temp->val->gc.flag.protect)
+	printf("(protected) ");
+#endif /* DEBUG */
       printf("%s\n", temp->id);
       temp= temp->next;
     }
@@ -935,21 +1002,20 @@
 extern void forget(environment *env)
 {
   char* sym_id;
-  value *stack_head= env->head;
 
-  if(stack_head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
   }
   
-  if(CAR(stack_head)->type!=symb) {
+  if(CAR(env->head)->type!=symb) {
     printerr("Bad Argument Type");
     env->err= 2;
     return;
   }
 
-  sym_id= CAR(stack_head)->content.sym->id;
+  sym_id= CAR(env->head)->content.sym->id;
   toss(env);
 
   return forget_sym(hash(env->symbols, sym_id));
@@ -983,7 +1049,7 @@
 	break;
       case '?':
 	fprintf (stderr,
-		 "Unknown option character `\\x%x'.\n",
+		 "Unknown option character '\\x%x'.\n",
 		 optopt);
 	return EX_USAGE;
       default:
@@ -1000,11 +1066,11 @@
   }
 
   if(myenv.interactive) {
-    printf("Stack version $Revision: 1.108 $\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\
+Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
 This is free software, and you are welcome to redistribute it\n\
-under certain conditions; type `copying;' for details.\n");
+under certain conditions; type 'copying;' for details.\n");
   }
 
   while(1) {
@@ -1019,10 +1085,11 @@
       }
       myenv.err=0;
     }
-    sx_72656164(&myenv);
-    if (myenv.err==4) {
-      return EXIT_SUCCESS;	/* EOF */
-    } else if(myenv.head!=NULL
+    sx_72656164(&myenv);	/* "read" */
+    if (myenv.err==4) {		/* EOF */
+      myenv.err=0;
+      quit(&myenv);
+    } else if(myenv.head->type!=empty
 	      && CAR(myenv.head)->type==symb
 	      && CAR(myenv.head)->content.sym->id[0]
 	      ==';') {
@@ -1044,7 +1111,7 @@
   char* new_string;
   value *a_val, *b_val;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1122,7 +1189,7 @@
   int a, b;
   float fa, fb;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err=1;
     return;
@@ -1182,7 +1249,7 @@
   int a, b;
   float fa, fb;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1274,6 +1341,7 @@
   case integer:
   case func:
   case symb:
+  case empty:
     new_value->content= old_value->content;
     break;
   case string:
@@ -1282,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 */
@@ -1298,7 +1367,7 @@
 /* "dup"; duplicates an item on the stack */
 extern void sx_647570(environment *env)
 {
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1311,7 +1380,7 @@
 {
   int truth;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1342,8 +1411,8 @@
 {
   int truth;
 
-  if(env->head==NULL || CDR(env->head)==NULL 
-     || CDR(CDR(env->head))==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty
+     || CDR(CDR(env->head))->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1375,8 +1444,31 @@
 
 extern void sx_656c7365(environment *env)
 {
-  if(env->head==NULL || CDR(env->head)==NULL 
-     || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty 
+     || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
+     || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(CDR(env->head))->type!=symb
+     || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
+     || CAR(CDR(CDR(CDR(env->head))))->type!=symb
+     || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  swap(env); toss(env); rot(env); toss(env);
+  ifelse(env);
+}
+
+extern void then(environment *env)
+{
+  if(env->head->type==empty || CDR(env->head)->type==empty
+     || CDR(CDR(env->head))->type==empty) { 
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1390,7 +1482,7 @@
   }
 
   swap(env); toss(env);
-  ifelse(env);
+  sx_6966(env);
 }
 
 /* "while" */
@@ -1399,7 +1491,7 @@
   int truth;
   value *loop, *test;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1445,8 +1537,8 @@
   value *loop;
   int foo1, foo2;
 
-  if(env->head==NULL || CDR(env->head)==NULL 
-     || CDR(CDR(env->head))==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty 
+     || CDR(CDR(env->head))->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1493,7 +1585,7 @@
   value *loop, *foo;
   value *iterator;
   
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1536,7 +1628,7 @@
   int ending, start, i;
   value *iterator, *temp;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1566,7 +1658,7 @@
 
   iterator= env->head;
 
-  if(iterator==NULL
+  if(iterator->type==empty
      || (CAR(iterator)->type==symb
 	 && CAR(iterator)->content.sym->id[0]=='[')) {
     temp= NULL;
@@ -1618,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) {
@@ -1652,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);
@@ -1688,7 +1783,7 @@
 {
   int freq, dur, period, ticks;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1733,7 +1828,7 @@
 {
   int dur;
 
-  if(env->head==NULL) {
+  if(env->head->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -1753,7 +1848,7 @@
 
 extern void copying(environment *env)
 {
-  printf("GNU GENERAL PUBLIC LICENSE\n\
+  printf("		    GNU GENERAL PUBLIC LICENSE\n\
 		       Version 2, June 1991\n\
 \n\
  Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
@@ -2042,7 +2137,7 @@
   int a, b;
   float fa, fb;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -2102,7 +2197,7 @@
   int a, b;
   float fa, fb;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -2161,7 +2256,7 @@
 {
   int a, b;
 
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -2187,7 +2282,7 @@
 {
   int a, b;
   
-  if(env->head==NULL || CDR(env->head)==NULL) {
+  if(env->head->type==empty || CDR(env->head)->type==empty) {
     printerr("Too Few Arguments");
     env->err= 1;
     return;
@@ -2207,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;
+}