--- stack/stack.c	2002/03/27 19:53:01	1.123
+++ stack/stack.c	2002/03/30 02:31:24	1.124
@@ -205,6 +205,7 @@
       case tcons:
 	free(env->gc_ref->item->content.c);
 	break;
+      case port:
       case empty:
       case integer:
       case tfloat:
@@ -462,11 +463,34 @@
 }
 
 /* Print newline. */
-extern void nl()
+extern void nl(environment *env)
 {
   printf("\n");
 }
 
+/* Print a newline to a port */
+extern void nlport(environment *env)
+{
+  if(env->head->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  if(fprintf(CAR(env->head)->content.p, "\n") < 0){
+    perror("nl");
+    env->err= 5;
+    return;
+  }
+  toss(env);
+}
+
 /* Gets the type of a value */
 extern void type(environment *env)
 {
@@ -498,42 +522,85 @@
   case tcons:
     push_sym(env, "pair");
     break;
+  case port:
+    push_sym(env, "port");
+    break;
   }
   swap(env);
   if (env->err) return;
   toss(env);
-}    
+}
 
 /* Print a value */
-void print_val(value *val, int noquote, stackitem *stack)
+void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
 {
   stackitem *titem, *tstack;
   int depth;
 
   switch(val->type) {
   case empty:
-    printf("[]");
+    if(fprintf(stream, "[]") < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     break;
   case integer:
-    printf("%d", val->content.i);
+    if(fprintf(stream, "%d", val->content.i) < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     break;
   case tfloat:
-    printf("%f", val->content.f);
+    if(fprintf(stream, "%f", val->content.f) < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     break;
   case string:
-    if(noquote)
-      printf("%s", (char*)(val->content.ptr));
-    else
-      printf("\"%s\"", (char*)(val->content.ptr));
+    if(noquote){
+      if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
+	perror("print_val");
+	env->err= 5;
+	return;
+      }
+    } else {			/* quote */
+      if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
+	perror("print_val");
+	env->err= 5;
+	return;
+      }
+    }
     break;
   case symb:
-    printf("%s", val->content.sym->id);
+    if(fprintf(stream, "%s", val->content.sym->id) < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     break;
   case func:
-    printf("#<function %p>", (funcp)(val->content.ptr));
+    if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
+    break;
+  case port:
+    if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     break;
   case tcons:
-    printf("[ ");
+    if(fprintf(stream, "[ ") < 0){
+      perror("print_val");
+      env->err= 5;
+      return;
+    }
     tstack= stack;
     do {
       titem=malloc(sizeof(stackitem));
@@ -550,9 +617,14 @@
 	depth++;
       }
       if(titem != NULL){	/* If we found it on the stack, */
-	printf("#%d#", depth);	/* print a depth reference */
+	if(fprintf(stream, "#%d#", depth) < 0){	/* print a depth reference */
+	  perror("print_val");
+	  env->err= 5;
+	  free(titem);
+	  return;
+	}
       } else {
-	print_val(CAR(val), noquote, tstack);
+	print_val(env, CAR(val), noquote, tstack, stream);
       }
       val= CDR(val);
       switch(val->type){
@@ -568,27 +640,49 @@
 	  depth++;
 	}
 	if(titem != NULL){	/* If we found it on the stack, */
-	  printf(" . #%d#", depth); /* print a depth reference */
+	  if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
+	    perror("print_val");
+	    env->err= 5;
+	    goto printval_end;
+	  }
 	} else {
-	  printf(" ");
+	  if(fprintf(stream, " ") < 0){
+	    perror("print_val");
+	    env->err= 5;
+	    goto printval_end;
+	  }
 	}
 	break;
       default:
-	printf(" . ");		/* Improper list */
-	print_val(val, noquote, tstack);
+	if(fprintf(stream, " . ") < 0){	/* Improper list */
+	  perror("print_val");
+	  env->err= 5;
+	  goto printval_end;
+        }
+	print_val(env, val, noquote, tstack, stream);
       }
     } while(val->type == tcons && titem == NULL);
+
+  printval_end:
+
     titem=tstack;
     while(titem != stack){
       tstack=titem->next;
       free(titem);
       titem=tstack;
     }
-    printf(" ]");
+
+    if(! (env->err)){
+      if(fprintf(stream, " ]") < 0){
+	perror("print_val");
+	env->err= 5;
+      }
+    }
     break;
   }
 }
 
+/* Print the top element of the stack but don't discard it */
 extern void print_(environment *env)
 {
   if(env->head->type==empty) {
@@ -596,11 +690,12 @@
     env->err= 1;
     return;
   }
-  print_val(CAR(env->head), 0, NULL);
-  nl();
+  print_val(env, CAR(env->head), 0, NULL, stdout);
+  if(env->err) return;
+  nl(env);
 }
 
-/* Prints the top element of the stack and then discards it. */
+/* Prints the top element of the stack */
 extern void print(environment *env)
 {
   print_(env);
@@ -608,6 +703,8 @@
   toss(env);
 }
 
+/* Print the top element of the stack without quotes, but don't
+   discard it. */
 extern void princ_(environment *env)
 {
   if(env->head->type==empty) {
@@ -615,10 +712,10 @@
     env->err= 1;
     return;
   }
-  print_val(CAR(env->head), 1, NULL);
+  print_val(env, CAR(env->head), 1, NULL, stdout);
 }
 
-/* Prints the top element of the stack and then discards it. */
+/* Prints the top element of the stack without quotes. */
 extern void princ(environment *env)
 {
   princ_(env);
@@ -626,14 +723,69 @@
   toss(env);
 }
 
-/* Only to be called by function printstack. */
-void print_st(value *stack_head, long counter)
+/* Print a value to a port, but don't discard it */
+extern void printport_(environment *env)
+{
+  if(env->head->type==empty ||  CDR(env->head)->type == empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
+  if(env->err) return;
+  nlport(env);
+}
+
+/* Print a value to a port */
+extern void printport(environment *env)
+{
+  printport_(env);
+  if(env->err) return;
+  toss(env);
+}
+
+/* Print, without quotes, to a port, a value, but don't discard it. */
+extern void princport_(environment *env)
+{
+  if(env->head->type==empty ||  CDR(env->head)->type == empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
+  toss(env); if(env->err) return;
+}
+
+/* Print, without quotes, to a port, the top element. */
+extern void princport(environment *env)
+{
+  princport_(env);
+  if(env->err) return;
+  toss(env);
+}
+
+/* Only to be called by itself function printstack. */
+void print_st(environment *env, value *stack_head, long counter)
 { 
   if(CDR(stack_head)->type != empty)
-    print_st(CDR(stack_head), counter+1);
+    print_st(env, CDR(stack_head), counter+1);
   printf("%ld: ", counter);
-  print_val(CAR(stack_head), 0, NULL);
-  nl();
+  print_val(env, CAR(stack_head), 0, NULL, stdout);
+  nl(env);
 }
 
 /* Prints the stack. */
@@ -644,7 +796,7 @@
     return;
   }
 
-  print_st(env->head, 1);
+  print_st(env, env->head, 1);
 }
 
 /* Swap the two top elements on the stack. */
@@ -780,9 +932,11 @@
     return;
 
   case empty:
+    toss(env); 
   case integer:
   case tfloat:
   case string:
+  case port:
     return;
   }
 }
@@ -1109,7 +1263,7 @@
   }
 
   if(myenv.interactive) {
-    printf("Stack version $Revision: 1.123 $\n\
+    printf("Stack version $Revision: 1.124 $\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\
@@ -1121,8 +1275,9 @@
       if (myenv.interactive) {
 	if(myenv.err) {
 	  printf("(error %d)\n", myenv.err);
+	  myenv.err= 0;
 	}
-	nl();
+	nl(&myenv);
 	printstack(&myenv);
 	printf("> ");
       }
@@ -1134,8 +1289,7 @@
       quit(&myenv);
     } else if(myenv.head->type!=empty
 	      && CAR(myenv.head)->type==symb
-	      && CAR(myenv.head)->content.sym->id[0]
-	      ==';') {
+	      && CAR(myenv.head)->content.sym->id[0] == ';') {
       toss(&myenv); 		/* No error check in main */
       eval(&myenv);
     }
@@ -1376,7 +1530,6 @@
   if(old_value==NULL)
     return NULL;
 
-  protect(old_value);
   new_value= new_val(env);
   new_value->type= old_value->type;
 
@@ -1386,6 +1539,7 @@
   case func:
   case symb:
   case empty:
+  case port:
     new_value->content= old_value->content;
     break;
   case string:
@@ -1403,8 +1557,6 @@
     break;
   }
 
-  unprotect(old_value);
-
   return new_value;
 }
 
@@ -1486,6 +1638,7 @@
   eval(env);
 }
 
+/* "else" */
 extern void sx_656c7365(environment *env)
 {
   if(env->head->type==empty || CDR(env->head)->type==empty 
@@ -1732,17 +1885,82 @@
 /* Read a string */
 extern void readline(environment *env)
 {
+  readlinestream(env, env->inputstream);
+}
+
+/* Read a string from a port */
+extern void readlineport(environment *env)
+{
+  FILE *stream;
+
+  if(env->head->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  stream=CAR(env->head)->content.p;
+  readlinestream(env, stream); if(env->err) return;
+
+  swap(env); if(env->err) return;
+  toss(env);
+}
+
+/* read a line from a stream; used by readline */
+void readlinestream(environment *env, FILE *stream)
+{
   char in_string[101];
 
-  if(fgets(in_string, 100, env->inputstream)==NULL)
+  if(fgets(in_string, 100, stream)==NULL) {
     push_cstring(env, "");
-  else
+    if (! feof(stream)){
+      perror("readline");
+      env->err= 5;
+    }
+  } else {
     push_cstring(env, in_string);
+  }
 }
 
 /* "read"; Read a value and place on stack */
 extern void sx_72656164(environment *env)
 {
+  readstream(env, env->inputstream);
+}
+
+/* "readport"; Read a value from a port and place on stack */
+extern void readport(environment *env)
+{
+  FILE *stream;
+
+  if(env->head->type==empty) {
+    printerr("Too Few Arguments");
+    env->err= 1;
+    return;
+  }
+
+  if(CAR(env->head)->type!=port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  stream=CAR(env->head)->content.p;
+  readstream(env, stream); if(env->err) return;
+
+  swap(env); if(env->err) return;
+  toss(env);
+}
+
+/* read from a stream; used by "read" and "readport" */
+void readstream(environment *env, FILE *stream)
+{
   const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
   const char strform[]= "\"%[^\"]\"%n";
   const char intform[]= "%i%n";
@@ -2527,8 +2745,80 @@
   toss(env);
 }
 
+/* "do" */
 extern void sx_646f(environment *env)
 {
   swap(env); if(env->err) return;
   eval(env);
 }
+
+/* "open" */
+/* 2: "file"					*/
+/* 1: "r"	=>	1: #<port 0x47114711>	*/
+extern void sx_6f70656e(environment *env)
+{
+  value *new_port;
+  FILE *stream;
+
+  if(env->head->type == empty || CDR(env->head)->type == empty) {
+    printerr("Too Few Arguments");
+    env->err=1;
+    return;
+  }
+
+  if(CAR(env->head)->type != string
+     || CAR(CDR(env->head))->type != string) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  stream=fopen(CAR(CDR(env->head))->content.ptr,
+	       CAR(env->head)->content.ptr);
+
+  if(stream == NULL) {
+    perror("open");
+    env->err= 5;
+    return;
+  }
+
+  new_port=new_val(env);
+  new_port->type=port;
+  new_port->content.p=stream;
+
+  push_val(env, new_port);
+
+  swap(env); if(env->err) return;
+  toss(env); if(env->err) return;
+  swap(env); if(env->err) return;
+  toss(env);
+}
+
+
+/* "close" */
+extern void sx_636c6f7365(environment *env)
+{
+  int ret;
+
+  if(env->head->type == empty) {
+    printerr("Too Few Arguments");
+    env->err=1;
+    return;
+  }
+
+  if(CAR(env->head)->type != port) {
+    printerr("Bad Argument Type");
+    env->err= 2;
+    return;
+  }
+
+  ret= fclose(CAR(env->head)->content.p);
+
+  if(ret != 0){
+    perror("close");
+    env->err= 5;
+    return;
+  }
+
+  toss(env);
+}