working on native I/O

TODO.FACTOR.txt

@@ -3,7 +3,6 @@
 - image output
 - 32-bit and 64-bit "bignums"
 - floats
-- i/o error handling
 - {...} vectors
 - parsing should be parsing
 - describe-word

library/platform/native/cross-compiler.factor

@@ -58,6 +58,7 @@ DEFER: accept-fd
 DEFER: read-line-fd-8
 DEFER: write-fd-8
 DEFER: flush-fd
+DEFER: shutdown-fd
 
 IN: words
 DEFER: <word>
@@ -156,6 +157,7 @@ IN: cross-compiler
         read-line-fd-8
         write-fd-8
         flush-fd
+        shutdown-fd
         room
     ] [
         swap succ tuck primitive,

library/platform/native/errors.factor

@@ -62,6 +62,7 @@ USE: vectors
         "Underflow"
         "Bad primitive: "
         "Incompatible handle: "
+        "I/O error: "
     ] ?nth ;
 
 : ?kernel-error ( cons -- error# param )

library/platform/native/stream.factor

@@ -86,9 +86,20 @@ USE: namespaces
         [ "socket" get close-fd ] "fclose" set
     ] extend ;
 
+: <socket-stream> ( fd -- stream )
+    #! A slight variation on <fd-stream> that calls shutdown(2)
+    #! when closed.
+    dup <fd-stream> [
+        ( -- )
+        [
+            "in"  get [ dup shutdown-fd close-fd ] when*
+            ( out == in )
+        ] "fclose" set
+    ] extend ;
+
 : accept ( server -- client )
     #! Accept a connection from a server socket.
-    [ "socket" get ] bind accept-fd dup <fd-stream> ;
+    [ "socket" get ] bind accept-fd <socket-stream> ;
 
 : init-stdio ( -- )
     stdin stdout <fd-stream> "stdio" set ;

native/cons.c

@@ -1,6 +1,6 @@
 #include "factor.h"
 
-CELL cons(CELL car, CELL cdr)
+CONS* cons(CELL car, CELL cdr)
 {
 	CONS* cons = (CONS*)allot(sizeof(CONS));
 	cons->car = car;

native/cons.h

@@ -14,7 +14,7 @@ INLINE CELL tag_cons(CONS* cons)
 	return RETAG(cons,CONS_TYPE);
 }
 
-CELL cons(CELL car, CELL cdr);
+CONS* cons(CELL car, CELL cdr);
 
 INLINE CELL car(CELL cons)
 {

native/error.c

@@ -50,5 +50,15 @@ void range_error(CELL tagged, CELL index, CELL max)
 {
 	CONS* c = cons(tagged,tag_cons(cons(tag_fixnum(index),
 		tag_cons(cons(tag_fixnum(max),F)))));
-	general_error(ERROR_RANGE,c);
+	general_error(ERROR_RANGE,tag_cons(c));
+}
+
+void io_error(const char* func)
+{
+	STRING* function = from_c_string(func);
+	STRING* error = from_c_string(strerror(errno));
+
+	CONS* c = cons(tag_object(function),tag_cons(
+		cons(tag_object(error),F)));
+	general_error(ERROR_IO,tag_cons(c));
 }

native/error.h

@@ -5,6 +5,7 @@
 #define ERROR_UNDERFLOW (4<<3)
 #define ERROR_BAD_PRIMITIVE (5<<3)
 #define ERROR_HANDLE_INCOMPAT (6<<3)
+#define ERROR_IO (7<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);
@@ -13,3 +14,4 @@ void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);
 void range_error(CELL tagged, CELL index, CELL max);
+void io_error(const char* func);

native/factor.h

@@ -12,6 +12,7 @@
 #include <sys/types.h>
 #include <sys/socket.h>
 #include <netinet/in.h>
+#include <arpa/inet.h>
 #include <unistd.h>
 
 #define INLINE inline static

native/fd.c

@@ -29,6 +29,7 @@ void primitive_read_line_fd_8(void)
 	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
 	int fd = h->object;
 
+	int amount;
 	int i;
 	int ch;
 
@@ -45,7 +46,12 @@ void primitive_read_line_fd_8(void)
 	{
 		if(h->buf_pos >= h->buf_fill)
 		{
-			if(fill_buffer(h,fd,buf) <= 0)
+			amount = fill_buffer(h,fd,buf);
+
+			if(amount < 0)
+				io_error(__FUNCTION__);
+
+			if(amount == 0)
 			{
 				if(line->top == 0)
 				{
@@ -82,7 +88,12 @@ void primitive_write_fd_8(void)
 	int fd = h->object;
 	STRING* str = untag_string(dpop());
 	char* c_str = to_c_string(str);
-	write(fd,c_str,str->capacity);
+	
+	int amount = write(fd,c_str,str->capacity);
+	
+	if(amount < 0)
+		io_error(__FUNCTION__);
+
 	env.dt = dpop();
 }
 
@@ -90,6 +101,20 @@ void primitive_flush_fd(void)
 {
 	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
 	int fd = h->object;
-	fsync(fd);
+
+	/* if(fsync(fd) < 0)
+		io_error(__FUNCTION__); */
+
+	env.dt = dpop();
+}
+
+void primitive_shutdown_fd(void)
+{
+	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
+	int fd = h->object;
+
+	if(shutdown(fd,SHUT_RDWR) < 0)
+		io_error(__FUNCTION__);
+
 	env.dt = dpop();
 }

native/fd.h

@@ -1,8 +1,10 @@
 #define LINE_SIZE 80
 #define BUF_SIZE 1024
 
+void init_io(void);
 void primitive_close_fd(void);
 int fill_buffer(HANDLE* h, int fd, STRING* buf);
 void primitive_read_line_fd_8(void);
 void primitive_write_fd_8(void);
 void primitive_flush_fd(void);
+void primitive_shutdown_fd(void);

native/file.c

@@ -14,7 +14,12 @@ void primitive_open_file(void)
 		mode = O_RDONLY;
 	else if(write)
 		mode = O_WRONLY | O_CREAT | O_TRUNC;
+	else
+		mode = 0;
 
 	fd = open(path,mode);
+	if(fd < 0)
+		io_error(__FUNCTION__);
+
 	env.dt = handle(HANDLE_FD,fd);
 }

native/primitives.c

@@ -87,7 +87,8 @@ XT primitives[] = {
 	primitive_read_line_fd_8,               /* 83 */
 	primitive_write_fd_8,                   /* 84 */
 	primitive_flush_fd,                     /* 85 */
-	primitive_room                          /* 86 */
+	primitive_shutdown_fd,                  /* 86 */
+	primitive_room                          /* 87 */
 };
 
 CELL primitive_to_xt(CELL primitive)
@@ -95,7 +96,7 @@ CELL primitive_to_xt(CELL primitive)
 	XT xt;
 
 	if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
-		general_error("Invalid primitive",tag_fixnum(primitive));
+		general_error(ERROR_BAD_PRIMITIVE,tag_fixnum(primitive));
 	
 	xt = primitives[primitive];
 	if((CELL)xt % 8 != 0)

native/primitives.h

@@ -1,5 +1,5 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 87
+#define PRIMITIVE_COUNT 88
 
 CELL primitive_to_xt(CELL primitive);
 

native/sbuf.c

@@ -30,7 +30,7 @@ void primitive_set_sbuf_length(void)
 	FIXNUM length = untag_fixnum(dpop());
 	sbuf->top = length;
 	if(length < 0)
-		range_error(env.dt,index,length);
+		range_error(env.dt,length,sbuf->top);
 	else if(length > sbuf->string->capacity)
 		sbuf->string = grow_string(sbuf->string,length,F);
 	env.dt = dpop(); /* don't forget this! */

native/socket.c

@@ -5,22 +5,34 @@ int make_server_socket(CHAR port)
 	int sock;
 	struct sockaddr_in name;
 	
+	int reuseaddr = 1;
+	
 	/* Create the socket */
 	sock = socket(PF_INET, SOCK_STREAM, 0);
 	
 	if(sock < 0)
-		return -1;
+		io_error(__FUNCTION__);
+	
+	/* Reuse port number */
+	if(setsockopt(sock,SOL_SOCKET,SO_REUSEADDR,&reuseaddr,sizeof(int)) < 0)
+		io_error(__FUNCTION__);
 	
 	/* Give the socket a name */
 	name.sin_family = AF_INET;
 	name.sin_port = htons(port);
 	name.sin_addr.s_addr = htonl(INADDR_ANY);
 	if(bind(sock,(struct sockaddr *)&name, sizeof(name)) < 0)
-		return -1;
+	{
+		close(sock);
+		io_error(__FUNCTION__);
+	}
 
 	/* Start listening for connections */
 	if(listen(sock,1) < 0)
-		return -1;
+	{
+		close(sock);
+		io_error(__FUNCTION__);
+	}
 
 	return sock;
 }
@@ -38,7 +50,7 @@ int accept_connection(int sock)
 	
 	int new = accept(sock,(struct sockaddr *)&clientname,&size);
 	if(new < 0)
-		return -1;
+		io_error(__FUNCTION__);
 
 	printf("Connection from host %s, port %hd.\n",
 		inet_ntoa(clientname.sin_addr),

native/string.c

@@ -51,7 +51,7 @@ STRING* grow_string(STRING* string, CELL capacity, CHAR fill)
 }
 
 /* untagged */
-STRING* from_c_string(char* c_string)
+STRING* from_c_string(const char* c_string)
 {
 	CELL length = strlen(c_string);
 	STRING* s = allot_string(length);
@@ -59,7 +59,7 @@ STRING* from_c_string(char* c_string)
 
 	for(i = 0; i < length; i++)
 	{
-		put(SREF(s,i),c_string);
+		put(SREF(s,i),*c_string);
 		c_string++;
 	}
 
@@ -101,7 +101,7 @@ void primitive_string_nth(void)
 	CELL index = untag_fixnum(dpop());
 
 	if(index < 0 || index >= string->capacity)
-		range_error(string,index,string->capacity);
+		range_error(tag_object(string),index,string->capacity);
 	env.dt = tag_fixnum(string_nth(string,index));
 }
 
@@ -160,7 +160,7 @@ void primitive_string_hashcode(void)
 INLINE CELL index_of_ch(CELL index, STRING* string, CELL ch)
 {
 	if(index < 0)
-		range_error(string,index,string->capacity);
+		range_error(tag_object(string),index,string->capacity);
 
 	while(index < string->capacity)
 	{
@@ -201,8 +201,11 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
 {
 	STRING* result;
 
-	if(start < 0 || end < start)
+	if(start < 0)
-		range_error(string,index,string->capacity);
+		range_error(tag_object(string),start,string->capacity);
+
+	if(end < start)
+		range_error(tag_object(string),end,string->capacity);
 
 	result = allot_string(end - start);
 	memcpy(result + 1,

native/string.h

@@ -17,7 +17,7 @@ STRING* string(CELL capacity, CELL fill);
 void hash_string(STRING* str);
 STRING* grow_string(STRING* string, CELL capacity, CHAR fill);
 char* to_c_string(STRING* s);
-STRING* from_c_string(char* c_string);
+STRING* from_c_string(const char* c_string);
 
 #define SREF(string,index) ((CELL)string + sizeof(STRING) + index * CHARS)
 

native/vector.c

@@ -30,7 +30,7 @@ void primitive_set_vector_length(void)
 	FIXNUM length = untag_fixnum(dpop());
 	vector->top = length;
 	if(length < 0)
-		range_error(vector,index,length);
+		range_error(tag_object(vector),length,vector->top);
 	else if(length > vector->array->capacity)
 		vector->array = grow_array(vector->array,length,F);
 	env.dt = dpop(); /* don't forget this! */
@@ -42,7 +42,7 @@ void primitive_vector_nth(void)
 	CELL index = untag_fixnum(dpop());
 
 	if(index < 0 || index >= vector->top)
-		range_error(vector,index,vector->top);
+		range_error(tag_object(vector),index,vector->top);
 	env.dt = array_nth(vector->array,index);
 }
 
@@ -64,7 +64,7 @@ void primitive_set_vector_nth(void)
 	check_non_empty(value);
 
 	if(index < 0)
-		range_error(vector,index,vector->top);
+		range_error(tag_object(vector),index,vector->top);
 	else if(index >= vector->top)
 		vector_ensure_capacity(vector,index);