some cleanup of run-file

native/error.c

@@ -6,8 +6,25 @@ void fatal_error(char* msg, CELL tagged)
 	exit(1);
 }
 
+void critical_error(char* msg, CELL tagged)
+{
+	printf("Critical error: %s %d\n",msg,tagged);
+	save_image("factor.crash.image");
+	exit(1);
+}
+
+void fix_stacks(void)
+{
+	if(env.ds < env.ds_bot + sizeof(ARRAY))
+		reset_datastack();
+	if(env.cs <= env.cs_bot + sizeof(ARRAY))
+		reset_callstack();
+}
+
 void throw_error(CELL error)
 {
+	fix_stacks();
+
 	dpush(env.dt);
 	env.dt = error;
 	/* Execute the 'throw' word */
@@ -19,14 +36,14 @@ void throw_error(CELL error)
 
 void general_error(CELL error, CELL tagged)
 {
-	CONS* c = cons(error,tag_cons(
-		cons(tagged,F)));
+	CONS* c = cons(error,tag_cons(cons(tagged,F)));
 	throw_error(tag_cons(c));
 }
 
 void type_error(CELL type, CELL tagged)
 {
-	CONS* c = cons(type,tag_cons(cons(tagged,F)));
+	printf("throwing %d %d\n",type,tagged);
+	CONS* c = cons(tag_fixnum(type),tag_cons(cons(tagged,F)));
 	general_error(ERROR_TYPE,tag_cons(c));
 }
 

native/error.h

@@ -3,8 +3,11 @@
 #define ERROR_TYPE (2<<3)
 #define ERROR_RANGE (3<<3)
 #define ERROR_UNDERFLOW (4<<3)
+#define ERROR_BAD_PRIMITIVE (5<<3)
 
 void fatal_error(char* msg, CELL tagged);
+void critical_error(char* msg, CELL tagged);
+void fix_stacks(void);
 void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);

native/gc.c

@@ -32,7 +32,7 @@ void copy_object(CELL* handle)
 	CELL header, newpointer;
 
 	if(in_zone(active,pointer))
-		fatal_error("copy_object given newspace ptr",pointer);
+		critical_error("copy_object given newspace ptr",pointer);
 
 	if(tag == FIXNUM_TYPE)
 	{
@@ -56,7 +56,7 @@ void copy_object(CELL* handle)
 	}
 	
 	if(tag == GC_COLLECTED)
-		fatal_error("installing forwarding pointer in newspace",newpointer);
+		critical_error("installing forwarding pointer in newspace",newpointer);
 
 	*handle = RETAG(newpointer,tag);
 }

native/image.c

@@ -10,7 +10,8 @@ void load_image(char* filename)
 	
 	file = fopen(filename,"rb");
 
-	fread(&h,sizeof(HEADER),1,file);
+	/* read it in native byte order */
+	fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
 
 	if(h.magic != IMAGE_MAGIC)
 		fatal_error("Bad magic number",h.magic);

native/memory.c

@@ -26,7 +26,7 @@ CELL allot(CELL a)
 	CELL h = active->here;
 	active->here = align8(active->here + a);
 	if(active->here > active->limit)
-		fatal_error("Out of memory",active->here);
+		critical_error("Out of memory",active->here);
 	return h;
 }
 

native/primitives.c

@@ -87,7 +87,7 @@ CELL primitive_to_xt(CELL primitive)
 	XT xt;
 
 	if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
-		fatal_error("Invalid primitive",primitive);
+		general_error("Invalid primitive",tag_fixnum(primitive));
 	
 	xt = primitives[primitive];
 	if((CELL)xt % 8 != 0)

native/run.c

@@ -7,18 +7,25 @@ void clear_environment(void)
 		env.user[i] = 0;
 }
 
+void reset_datastack(void)
+{
+	env.ds = UNTAG(env.ds_bot) + sizeof(ARRAY);
+	env.dt = empty;
+}
+
+void reset_callstack(void)
+{
+	env.cs = UNTAG(env.cs_bot) + sizeof(ARRAY);
+	cpush(empty);
+}
+
 void init_environment(void)
 {
 	/* + CELLS * 2 to skip header and length cell */
-	env.ds_bot = (CELL)array(STACK_SIZE,empty);
-	env.ds = env.ds_bot + sizeof(ARRAY);
-	env.ds_bot = tag_object(env.ds_bot);
-	/* dpush(empty); */
-	env.dt = empty;
-	env.cs_bot = (CELL)array(STACK_SIZE,empty);
-	env.cs = env.cs_bot + sizeof(ARRAY);
-	env.cs_bot = tag_object(env.cs_bot);
-	cpush(empty);
+	env.ds_bot = tag_object(array(STACK_SIZE,empty));
+	reset_datastack();
+	env.cs_bot = tag_object(array(STACK_SIZE,empty));
+	reset_callstack();
 	env.cf = env.boot;
 }
 

native/types.c

@@ -60,7 +60,7 @@ CELL object_size(CELL pointer)
 	case OBJECT_TYPE:
 		return untagged_object_size(UNTAG(pointer));
 	default:
-		fatal_error("Cannot determine size",pointer);
+		critical_error("Cannot determine size",pointer);
 		return -1;
 	}
 }
@@ -90,7 +90,7 @@ CELL untagged_object_size(CELL pointer)
 		size = sizeof(SBUF);
 		break;
 	default:
-		fatal_error("Cannot determine size",relocating);
+		critical_error("Cannot determine size",relocating);
 		size = -1;/* can't happen */
 		break;
 	}

native/types.h

@@ -61,7 +61,7 @@ INLINE CELL tag_header(CELL cell)
 INLINE CELL untag_header(CELL cell)
 {
 	if(TAG(cell) != HEADER_TYPE)
-		fatal_error("header type check",cell);
+		critical_error("header type check",cell);
 	return cell >> TAG_BITS;
 }