Pārlūkot izejas kodu

catch Stack_overflow

Nicolas Cannasse 13 gadi atpakaļ
vecāks
revīzija
998b114331
1 mainītis faili ar 48 papildinājumiem un 47 dzēšanām
  1. 48 47
      interp.ml

+ 48 - 47
interp.ml

@@ -303,12 +303,12 @@ let nargs = function
 let rec get_field o fid =
 let rec get_field o fid =
 	let rec loop min max =
 	let rec loop min max =
 		if min < max then begin
 		if min < max then begin
-			let mid = (min + max) lsr 1 in
-			let cid, v = Array.unsafe_get o.ofields mid in
-			if cid < fid then
-				loop (mid + 1) max
-			else if cid > fid then
-				loop min mid
+			let mid = (min + max) lsr 1 in
+			let cid, v = Array.unsafe_get o.ofields mid in
+			if cid < fid then
+				loop (mid + 1) max
+			else if cid > fid then
+				loop min mid
 			else
 			else
 				v
 				v
 		end else
 		end else
@@ -320,13 +320,13 @@ let rec get_field o fid =
 
 
 let set_field o fid v =
 let set_field o fid v =
 	let rec loop min max =
 	let rec loop min max =
-		let mid = (min + max) lsr 1 in
+		let mid = (min + max) lsr 1 in
 		if min < max then begin
 		if min < max then begin
-			let cid, _ = Array.unsafe_get o.ofields mid in
-			if cid < fid then
-				loop (mid + 1) max
-			else if cid > fid then
-				loop min mid
+			let cid, _ = Array.unsafe_get o.ofields mid in
+			if cid < fid then
+				loop (mid + 1) max
+			else if cid > fid then
+				loop min mid
 			else
 			else
 				Array.unsafe_set o.ofields mid (cid,v)
 				Array.unsafe_set o.ofields mid (cid,v)
 		end else
 		end else
@@ -339,13 +339,13 @@ let set_field o fid v =
 
 
 let rec remove_field o fid =
 let rec remove_field o fid =
 	let rec loop min max =
 	let rec loop min max =
-		let mid = (min + max) lsr 1 in
+		let mid = (min + max) lsr 1 in
 		if min < max then begin
 		if min < max then begin
-			let cid, v = Array.unsafe_get o.ofields mid in
-			if cid < fid then
-				loop (mid + 1) max
-			else if cid > fid then
-				loop min mid
+			let cid, v = Array.unsafe_get o.ofields mid in
+			if cid < fid then
+				loop (mid + 1) max
+			else if cid > fid then
+				loop min mid
 			else begin
 			else begin
 				let fields = Array.make (Array.length o.ofields - 1) (fid,VNull) in
 				let fields = Array.make (Array.length o.ofields - 1) (fid,VNull) in
 				Array.blit o.ofields 0 fields 0 mid;
 				Array.blit o.ofields 0 fields 0 mid;
@@ -361,12 +361,12 @@ let rec remove_field o fid =
 let rec get_field_opt o fid =
 let rec get_field_opt o fid =
 	let rec loop min max =
 	let rec loop min max =
 		if min < max then begin
 		if min < max then begin
-			let mid = (min + max) lsr 1 in
-			let cid, v = Array.unsafe_get o.ofields mid in
-			if cid < fid then
-				loop (mid + 1) max
-			else if cid > fid then
-				loop min mid
+			let mid = (min + max) lsr 1 in
+			let cid, v = Array.unsafe_get o.ofields mid in
+			if cid < fid then
+				loop (mid + 1) max
+			else if cid > fid then
+				loop min mid
 			else
 			else
 				Some v
 				Some v
 		end else
 		end else
@@ -1698,7 +1698,7 @@ let macro_lib =
 		"error", Fun2 (fun msg p ->
 		"error", Fun2 (fun msg p ->
 			match msg, p with
 			match msg, p with
 			| VString s, VAbstract (APos p) ->
 			| VString s, VAbstract (APos p) ->
-				(ccom()).Common.error s p;
+				(ccom()).Common.error s p;
 				raise Abort
 				raise Abort
 			| _ -> error()
 			| _ -> error()
 		);
 		);
@@ -1928,16 +1928,16 @@ let macro_lib =
 			let t = decode_type v in
 			let t = decode_type v in
 			let follow_once t =
 			let follow_once t =
 				match t with
 				match t with
-				| TMono r ->
-					(match !r with
-					| None -> t
-					| Some t -> t)
-				| TEnum _ | TInst _ | TFun _ | TAnon _ | TDynamic _ ->
-					t
-				| TType (t,tl) ->
-					apply_params t.t_types tl t.t_type
-				| TLazy f ->
-					(!f)()
+				| TMono r ->
+					(match !r with
+					| None -> t
+					| Some t -> t)
+				| TEnum _ | TInst _ | TFun _ | TAnon _ | TDynamic _ ->
+					t
+				| TType (t,tl) ->
+					apply_params t.t_types tl t.t_type
+				| TLazy f ->
+					(!f)()
 			in
 			in
 			encode_type (match once with VNull | VBool false -> follow t | VBool true -> follow_once t | _ -> error())
 			encode_type (match once with VNull | VBool false -> follow t | VBool true -> follow_once t | _ -> error())
 		);
 		);
@@ -2663,6 +2663,7 @@ and call ctx vthis vfun pl p =
 		| _ ->
 		| _ ->
 			exc (VString "Invalid call"))
 			exc (VString "Invalid call"))
 	with Return v -> v
 	with Return v -> v
+		| Stack_overflow -> exc (VString "Compiler Stack overflow")
 		| Sys_error msg | Failure msg -> exc (VString msg)
 		| Sys_error msg | Failure msg -> exc (VString msg)
 		| Unix.Unix_error (_,cmd,msg) -> exc (VString ("Error " ^ cmd ^ " " ^ msg))
 		| Unix.Unix_error (_,cmd,msg) -> exc (VString ("Error " ^ cmd ^ " " ^ msg))
 		| Builtin_error | Invalid_argument _ -> exc (VString "Invalid call")) in
 		| Builtin_error | Invalid_argument _ -> exc (VString "Invalid call")) in
@@ -2826,7 +2827,7 @@ let add_types ctx types =
 			true;
 			true;
 		end
 		end
 	) types in
 	) types in
-	Codegen.post_process types [Codegen.captured_vars ctx.com];
+	Codegen.post_process types [Codegen.captured_vars ctx.com];
 	let e = (EBlock (Genneko.build ctx.gen types), null_pos) in
 	let e = (EBlock (Genneko.build ctx.gen types), null_pos) in
 	ignore(catch_errors ctx (fun() -> ignore((eval ctx e)())))
 	ignore(catch_errors ctx (fun() -> ignore((eval ctx e)())))
 
 
@@ -3030,12 +3031,12 @@ and encode_tparam = function
 
 
 and encode_access a =
 and encode_access a =
 	let tag = match a with
 	let tag = match a with
-		| APublic -> 0
-		| APrivate -> 1
-		| AStatic -> 2
-		| AOverride -> 3
-		| ADynamic -> 4
-		| AInline -> 5
+		| APublic -> 0
+		| APrivate -> 1
+		| AStatic -> 2
+		| AOverride -> 3
+		| ADynamic -> 4
+		| AInline -> 5
 	in
 	in
 	enc_enum IAccess tag []
 	enc_enum IAccess tag []
 
 
@@ -3308,11 +3309,11 @@ and decode_fun v =
 
 
 and decode_access v =
 and decode_access v =
 	match decode_enum v with
 	match decode_enum v with
-	| 0, [] -> APublic
-	| 1, [] -> APrivate
-	| 2, [] -> AStatic
-	| 3, [] -> AOverride
-	| 4, [] -> ADynamic
+	| 0, [] -> APublic
+	| 1, [] -> APrivate
+	| 2, [] -> AStatic
+	| 3, [] -> AOverride
+	| 4, [] -> ADynamic
 	| 5, [] -> AInline
 	| 5, [] -> AInline
 	| _ -> raise Invalid_expr
 	| _ -> raise Invalid_expr