CLANNADFVProgress

CLANNAD FV Progress

OCaml debugging

I have added debugging features to the 1.41 SVN version of kprl. This can be turned on and off by a flag at the top of the file (called debug). I have also found the XOR-key for CLANNAD FV which is 0xAF2FFB6BAF3077178748FE2C681AB9F0. In order to disassemble make sure to specify the version, 1.5.0.4. Example:

kprl.exe --target-version=1.5.0.4 -u -e utf-8 -d SEEN.txt

Patch for both is below:

Patch

diff -r c4b81f2aba09 -r 7a2e6f20133b src/OMakefile
--- a/src/OMakefile	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/OMakefile	Wed Jun 11 19:37:30 2008 -0700
@@ -21,6 +21,7 @@
 USE_OCAMLFIND = true
 
 if $(defined-env DEBUG)
+  echo "Debug mode"
   NATIVE_ENABLED = false
   BYTE_ENABLED = true
   OCAMLFLAGS += -g -custom
diff -r c4b81f2aba09 -r 7a2e6f20133b src/common/lz_comp_rl.cpp
--- a/src/common/lz_comp_rl.cpp	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/common/lz_comp_rl.cpp	Wed Jun 11 19:37:30 2008 -0700
@@ -1,3 +1,4 @@
+
 /*
    Kprl: RealLive compressor.
    Copyright (C) 2006 Haeleth
@@ -48,13 +49,48 @@
     0xb0, 0x43, 0x00, 0x85, 0xff, 0x76, 0x49, 0x81, 0xff, 0x00, 0x00, 0x04,
     0x00, 0x6a, 0x00, 0x76
 };
+/*static uchar xor_mask[] = {
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+    0x00, 0x00, 0x00, 0x00
+};*/
 
 /* In some new titles, a second round of XORing is performed on a
  * block of uncompressed bytecode, using the following 16-byte key: */
-static uchar xor_mask_2[] = {
+/*static uchar xor_mask_2[] = {
     0xa8, 0x28, 0xfd, 0x66, 0xa0, 0x23, 0x77, 0x69, 0xf9, 0x45, 0xf8, 0x2c,
     0x7c, 0x00, 0xad, 0xf4
+};*/
+#if(1)
+static uchar xor_mask_2[] = {
+    0xAF, 0x2F, 0xFB, 0x6B, 0xAF, 0x30, 0x77, 0x17, 0x87, 0x48, 0xFE, 0x2C, 
+	0x68, 0x1A, 0xB9, 0xF0
 };
+#else
+static uchar xor_mask_2[] = {
+    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+    0x00, 0x00, 0x00, 0x00
+};
+#endif
 
 /* Decrypt an "encrypted" file */
 value rl_prim_apply_mask (value array, value origin)
@@ -104,8 +140,10 @@
         bit <<= 1;
     }
     if (Bool_val(use_xor_2)) {
-	dst = dststart + 256;
-	for (int i = 0; i < 257; ++i) *dst++ ^= xor_mask_2[i % 16];
+		dst = dststart + 256;
+		for (int i = 0; i < 257; ++i) {	
+			*dst++ ^= xor_mask_2[i % 16];
+		}
     }
     CAMLreturn(Val_unit);
 }
diff -r c4b81f2aba09 -r 7a2e6f20133b src/common/optpp.ml
--- a/src/common/optpp.ml	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/common/optpp.ml	Wed Jun 11 19:37:30 2008 -0700
@@ -123,10 +123,31 @@
   flush stderr;
   Format.set_formatter_out_channel stdout
 
+exception Error of string
+let abort s = raise (Error s)
+
+exception Trace of string * int
+
+let startTrace s =
+	raise (Trace ((sprintf "%s\nStack Trace:" s), 0))
+	
+let contTrace s n sn =
+	let rec gen_space n =
+		match n with
+			| 0 -> ""
+			| _ -> "   " ^ gen_space (n-1) in			
+	raise (Trace ( (s ^ (sprintf "\n") ^ gen_space(n) ^ sn), n+1))
+	
+let printTrace s n =
+  Format.set_formatter_out_channel stderr;
+  cliInfo (sprintf "%s\n%d levels traced" s n)
+
+let cliErrorDisp s =
+  Format.set_formatter_out_channel stderr;
+  cliInfo s
+
 let cliError s =
-  Format.set_formatter_out_channel stderr;
-  cliInfo s;
-  exit 2
+  abort s
 
 let usageError ?(app = default_app_info) s =
   ksprintf cliError "Error: %s.\nFor basic usage information run `%s --help'" s app.exe_name
@@ -136,8 +157,6 @@
 let sysError s = ksprintf cliError "Error: %s." s
 
 
-exception Error of string
-let abort s = raise (Error s)
 
 let noshort = '\000'
 let nolong  = ""
diff -r c4b81f2aba09 -r 7a2e6f20133b src/common/optpp.mli
--- a/src/common/optpp.mli	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/common/optpp.mli	Wed Jun 11 19:37:30 2008 -0700
@@ -65,6 +65,11 @@
 (* Option parsing *)
 
 exception Error of string
+exception Trace of string * int
+
+val startTrace : string -> 'a
+val contTrace : string -> int -> string -> 'a
+val printTrace : string -> int -> unit
 
 val display_version : app_info -> unit
 val display_help : app_info -> opt_srcp list -> 'a
@@ -80,6 +85,7 @@
 
 val cliWarning : string -> unit
 val cliError : string -> 'a
+val cliErrorDisp : string -> unit
 
 val sysInfo : string -> unit
 val sysWarning : string -> unit
diff -r c4b81f2aba09 -r 7a2e6f20133b src/kprl/disassembler.ml
--- a/src/kprl/disassembler.ml	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/kprl/disassembler.ml	Wed Jun 11 19:37:30 2008 -0700
@@ -22,6 +22,8 @@
 open ExtString
 open Ulexing
 open KfnTypes
+
+let debug = true
 
 (* The actual ISet module appears to have issues. :/ *)
 module ISet = Set.Make (struct type t = int;; let compare = compare end)
@@ -309,11 +311,34 @@
 let regexp sjs2 = ['\x40'-'\x7e' '\x80'-'\xfc']
 
 (* Lexer utility functions *)
+   
+let printbytes lexbuf n1 =
+	if n1 < 0 then ""
+	else
+		let rec readbytes_h n = (
+			match n with
+				| 0 -> ""
+				| _ -> let f = (lexer
+							| eof -> " eof"
+							| _ -> (let c = (lexeme_char lexbuf 0) in
+									let s = sprintf "0x%02x " c ^ readbytes_h (n - 1) in
+									rollback lexbuf;
+									s)) in
+							f lexbuf) in
+		readbytes_h n1
+		
 
 let error lexbuf s =
-  ksprintf sysError "%s near 0x%06x" (Text.sjs_to_err s) (lexeme_start lexbuf + !data_offset)
+	try
+		ksprintf sysError "%s near 0x%06x" (Text.sjs_to_err s) (lexeme_start lexbuf + !data_offset)
+	with
+		| Optpp.Error s ->
+			if debug then
+				ksprintf Optpp.cliError "%s\nNext 100 bytes:\n%s" s (printbytes lexbuf 100)
+			else
+				ksprintf Optpp.cliError "%s" s
 
-and warning lexbuf s =
+let warning lexbuf s =
   ksprintf sysWarning "%s near 0x%06x" (Text.sjs_to_err s) (lexeme_start lexbuf + !data_offset)
 
 let get_int32 = lexer _ _ _ _ ->
@@ -358,8 +383,15 @@
 
 (* Expressions. *)
 
-let variable_name lexbuf =
-  function
+let dp s = 
+	if debug then printf "%s%!" s
+
+let pns s = 
+	dp (sprintf "%s\n" s);
+	s
+	
+let variable_name lexbuf c =
+	let decode =  function
     | 0x0a -> Config.svar_prefix ^ "K"   | 0x0b -> Config.ivar_prefix ^ "L"
     | 0x0c -> Config.svar_prefix ^ "M"   | 0x12 -> Config.svar_prefix ^ "S"
     | 0x00 -> Config.ivar_prefix ^ "A"   | 0x01 -> Config.ivar_prefix ^ "B"
@@ -383,37 +415,57 @@
     | 0x6c -> Config.ivar_prefix ^ "E8b" | 0x6d -> Config.ivar_prefix ^ "F8b"
     | 0x6e -> Config.ivar_prefix ^ "G8b" | 0x81 -> Config.ivar_prefix ^ "Z8b"
     | i -> ksprintf (warning lexbuf) "unrecognised variable index 0x%02x in variable_name" i;
-           sprintf "VAR%02x" i
+           sprintf "VAR%02x" i in
+	pns (decode c)
 
+				(*  1    2    3    4    5    6    7    8     9   10    11 *)
 let op_string = [| "+"; "-"; "*"; "/"; "%"; "&"; "|"; "^"; "<<"; ">>"; "" |]
+
 
 
 (* Kepago operator precedences differ from those used internally by RealLive, so 
    we use a recursive-descent parser to build expression trees (get_expr_*
    functions) and flatten that with appropriate parentheses in get_expression. *)
 
-let rec get_expr_token =
-  lexer
+let rec get_expr_token lexbuf =
+  let f = lexer
     | 0xff -> Int32.to_string (get_int32 lexbuf)
     | 0xc8 -> "store"
     | [^ 0xc8 0xff] '['
       -> let i = variable_name lexbuf (lexeme_char lexbuf 0) in
-         let e = get_expression lexbuf in
-         expect lexbuf ']' "get_expr_token";
-         sprintf "%s[%s]" i e
+		let e = get_expression lexbuf in
+			(try 
+				expect lexbuf ']' "get_expr_token";
+				sprintf "%s[%s]" i e
+			with
+				| Optpp.Error s -> ksprintf Optpp.startTrace "%s\nExpression so far:\n%s[%s]\n"	s i e)
     | eof -> error lexbuf "unexpected end of file in get_expr_token"
-    | _ -> ksprintf (error lexbuf) "unknown token type 0x%02x in get_expr_token" (lexeme_char lexbuf 0)
+    | _ -> ksprintf (error lexbuf) "unknown token type 0x%02x in get_expr_token" (lexeme_char lexbuf 0) in
+	try
+		f lexbuf
+	with
+		| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expr_token"
 
-and get_expr_term =
-  lexer
-    | "$" -> `Atom (get_expr_token lexbuf)
-    | "\\\000" -> (* Unary plus?  We ignore it, anyway. *) get_expr_term lexbuf
-    | "\\\001" -> `Minus (get_expr_term lexbuf)
-    | "(" -> let c = get_expr_bool lexbuf in
-             expect lexbuf ')' "get_expr_term";
-             c
-    | eof -> error lexbuf "unexpected end of file in get_expr_term"
-    | _ -> ksprintf (error lexbuf) "expected [$\\(] in get_expr_term, found 0x%02x" (lexeme_char lexbuf 0)
+and get_expr_term lexbuf =
+	let f = lexer
+	    | "$" -> `Atom (get_expr_token lexbuf)
+	    | "\\\000" -> (* Unary plus?  We ignore it, anyway. *) get_expr_term lexbuf
+	    | "\\\001" -> `Minus (get_expr_term lexbuf)
+	    | "(" -> let c = get_expr_bool lexbuf in
+			(try 
+				expect lexbuf ')' "get_expr_term";
+				c
+			with
+				| Optpp.Error s -> ksprintf Optpp.startTrace "%s" s)
+	    | eof -> error lexbuf "unexpected end of file in get_expr_term"
+	    | _ -> (try
+					ksprintf (error lexbuf) "expected [$\\(] in get_expr_term, found 0x%02x" (lexeme_char lexbuf 0)
+				with
+					| Optpp.Error s -> ksprintf Optpp.startTrace "%s" s) in
+		try
+			f lexbuf
+		with
+			| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expr_term"
 
 and get_expr_arith lexbuf =
   let rec loop_hi_prec tok =
@@ -435,7 +487,10 @@
       | _ -> rollback lexbuf;
              tok
   in
-  loop (loop_hi_prec (get_expr_term lexbuf) lexbuf) lexbuf
+	try
+		loop (loop_hi_prec (get_expr_term lexbuf) lexbuf) lexbuf
+	with
+		| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expr_arith"
 
 and get_expr_cond lexbuf =
   let rec loop tok =
@@ -448,7 +503,10 @@
       | _ -> rollback lexbuf;
              tok
   in
-  loop (get_expr_arith lexbuf) lexbuf
+	try
+		loop (get_expr_arith lexbuf) lexbuf
+	with
+		| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expr_cond"
 
 and get_expr_bool lexbuf =
   let rec loop_and tok =
@@ -458,7 +516,11 @@
     lexer "\\=" -> loop_or (`Binary (tok, 0x3d, loop_and (get_expr_cond lexbuf) lexbuf)) lexbuf
       | eof | _ -> rollback lexbuf; tok
   in
-  loop_or (loop_and (get_expr_cond lexbuf) lexbuf) lexbuf
+	try
+		loop_or (loop_and (get_expr_cond lexbuf) lexbuf) lexbuf
+	with
+		| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expr_bool"
+	
 
 and get_expression =
   let op_string x =
@@ -479,36 +541,40 @@
   in
   let rec traverse =
     function
-      | `Atom s -> s
-      | `Minus (`Atom s) -> sprintf "-%s" s
-      | `Minus (`Minus e) -> traverse e
-      | `Minus (`Binary _ as e) -> sprintf "-(%s)" (traverse e)
+      | `Atom s -> dp "atom "; pns s
+      | `Minus (`Atom s) -> ksprintf pns "-%s" s
+      | `Minus (`Minus e) -> dp "--atom\n"; traverse e
+      | `Minus (`Binary _ as e) -> ksprintf pns "-(%s)" (traverse e)
       (* TODO: special cases *) 
       | `Binary (a, op, b) 
          -> let a' = traverse a
             and b' =
               match b with
                 | `Binary (_, bop, _) when prec bop <= prec op 
-                    -> let t = traverse b in if t.[0] = '~' then t else sprintf "(%s)" t
+                    -> let t = traverse b in if t.[0] = '~' then t else ksprintf pns "(%s)" t
                 | _ -> traverse b
             in
             if op = 0x07 && b' = "-1" then
-              sprintf "~%s" (match a with `Binary _ -> sprintf "(%s)" a' | _ -> a')
+              sprintf "~%s" (match a with `Binary _ -> ksprintf pns "(%s)" a' | _ -> a')
             else if op = 0x28 && b' = "0" then
-              sprintf "!%s" (match a with `Binary _ -> sprintf "(%s)" a' | _ -> a')
+              sprintf "!%s" (match a with `Binary _ -> ksprintf pns "(%s)" a' | _ -> a')
             else if op = 0x29 && b' = "0" then
               a'
             else
               let a'' =
                 match a with
                   | `Binary (_, aop, _) when prec aop < prec op 
-                      -> sprintf "(%s)" a'
+                      -> ksprintf pns "(%s)" a'
                   | _ -> a'
               in
-              sprintf "%s %s %s" a'' (op_string op) b'
+              ksprintf pns "%s %s %s" a'' (op_string op) b'
   in
   fun lexbuf -> 
-    traverse (get_expr_bool lexbuf)
+	try
+		traverse (get_expr_bool lexbuf)
+	with
+		| Optpp.Trace (s, n)  -> Optpp.contTrace s n "get_expression"
+		
 
 and get_assignment cmd =
   let op =
@@ -516,9 +582,9 @@
       | '\\' [0x14-0x1e] -> op_string.(lexeme_char lexbuf 1 - 0x14)
       | _ -> ksprintf (error lexbuf) "expected 0x5c[14-1e], found 0x%02x in get_assignment" (lexeme_char lexbuf 0)
   in fun lexbuf ->
-    let itok = get_expr_token lexbuf in
-    let op = op lexbuf in
-    let etok = get_expression lexbuf in
+    let itok = try get_expr_token lexbuf with | Optpp.Trace (s, n) -> Optpp.contTrace s n "get_assignment" in
+    let op = op lexbuf in	
+    let etok = try get_expression lexbuf with | Optpp.Trace (s, n) -> Optpp.contTrace s n (sprintf "get_assignment: %s %s= " itok op) in
     (* Check for assignments to/from STORE and fake return values as appropriate *)
     let unstored =
       if etok = "store"  then
@@ -877,7 +943,10 @@
                loop b true (n - 1) lexbuf)
       lexbuf
     in
-    expect lexbuf '(' "read_unknown_function";
+	(try
+		expect lexbuf '(' "read_unknown_function"
+	with
+		| Optpp.Error s -> ksprintf Optpp.startTrace "%s\nExpression so far:\n%s\n"	s opstr);
     let buffer = Buffer.create 0 in
     bprintf buffer "%s (" opstr;
     loop buffer false argc lexbuf;
@@ -1098,8 +1167,8 @@
              read_unknown_function cmd opstr argc lexbuf
 
 
-let read_command hdr mode version =
-  lexer
+let read_command hdr mode version lexbuf2 =
+  let f = (lexer
     (* ends in themselves *)
     | eof -> raise End_of_file
     | '\000' -> command { base_cmd lexbuf with is_jmp = true } "halt"
@@ -1152,7 +1221,11 @@
     (* textout *)
     | _ -> let c = base_cmd lexbuf in
            rollback lexbuf;
-           read_textout c lexbuf
+           read_textout c lexbuf) in
+	try
+		f lexbuf2
+	with
+		| Optpp.Trace (s, n) -> Optpp.contTrace s n "read_command"
 
 
 let disassemble fname (arr: Binarray.t) =
@@ -1217,7 +1290,21 @@
   try
     reset_state ();
     data_offset := aorg;
-    while true do read_command hdr mode mode_version lexbuf done
+		while true do
+			let last_good = (lexeme_start lexbuf + !data_offset)-1 in
+				let abort_fun f s = (
+					if debug then (
+						f ();
+						printf "!!!ERROR!!!\nFailed to parse, outputting what was found.\nLast good decode ended at 0x%06x\n!!!ERROR!!!" last_good;
+						raise End_of_file )
+					else
+						cliError s) in
+				try
+					read_command hdr mode mode_version lexbuf
+				with
+					| Optpp.Error s -> abort_fun (fun () -> cliErrorDisp s) s
+					| Optpp.Trace (s, c) -> abort_fun (fun () -> printTrace s c) s
+		done
   with
     End_of_file ->
       let _, labels =
diff -r c4b81f2aba09 -r 7a2e6f20133b src/kprl/main.ml
--- a/src/kprl/main.ml	Mon Aug 06 14:21:58 2007 -0700
+++ b/src/kprl/main.ml	Wed Jun 11 19:37:30 2008 -0700
@@ -259,3 +259,5 @@
     | Failure "help"    -> display_help App.app options
     | Failure "version" -> display_version App.app
     | Failure e         -> sysError e
+	| Error s			-> cliErrorDisp s; exit 2
+	| Trace (s,n)		-> printTrace s n; exit 2

Litghost 19:49, 11 June 2008 (PDT)