From 87dff417054ef8a1f6830064957d3d5d596ff1b4 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Mon, 8 Jan 2024 09:04:49 +0100 Subject: [PATCH] also port genhl to gctx --- src/compiler/generate.ml | 4 +- src/context/common.ml | 88 ++--------------------------------- src/core/stringHelper.ml | 90 +++++++++++++++++++++++++++++++++++- src/generators/gctx.ml | 25 +++++++++- src/generators/genhl.ml | 30 ++++++------ src/generators/genjs.ml | 2 +- src/generators/hl2c.ml | 8 ++-- src/generators/hlinterp.ml | 16 +++---- src/macro/eval/evalStdLib.ml | 2 +- 9 files changed, 149 insertions(+), 116 deletions(-) diff --git a/src/compiler/generate.ml b/src/compiler/generate.ml index b3d724b439d..d6e17af1e65 100644 --- a/src/compiler/generate.ml +++ b/src/compiler/generate.ml @@ -88,7 +88,9 @@ let generate ctx tctx ext actx = | Python -> Genpy.generate,"python" | Hl -> - Genhl.generate,"hl" + (fun com -> + Genhl.generate (Common.to_gctx com) + ),"hl" | Eval -> (fun _ -> MacroContext.interpret tctx),"eval" | Cross diff --git a/src/context/common.ml b/src/context/common.ml index 0be89298028..7fb667144b8 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -416,8 +416,12 @@ let to_gctx com = { Gctx.platform = com.platform; defines = com.defines; basic = com.basic; + class_path = com.class_path; + run_command = com.run_command; + run_command_args = com.run_command_args; debug = com.debug; file = com.file; + version = com.version; features = com.features; modules = com.modules; main = com.main; @@ -1191,90 +1195,6 @@ let hash f = done; if Sys.word_size = 64 then Int32.to_int (Int32.shift_right (Int32.shift_left (Int32.of_int !h) 1) 1) else !h -let url_encode s add_char = - let hex = "0123456789ABCDEF" in - for i = 0 to String.length s - 1 do - let c = String.unsafe_get s i in - match c with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' -> - add_char c - | _ -> - add_char '%'; - add_char (String.unsafe_get hex (int_of_char c lsr 4)); - add_char (String.unsafe_get hex (int_of_char c land 0xF)); - done - -let url_encode_s s = - let b = Buffer.create 0 in - url_encode s (Buffer.add_char b); - Buffer.contents b - -(* UTF8 *) - -let to_utf8 str p = - let u8 = try - UTF8.validate str; - str; - with - UTF8.Malformed_code -> - (* ISO to utf8 *) - let b = UTF8.Buf.create 0 in - String.iter (fun c -> UTF8.Buf.add_char b (UCharExt.of_char c)) str; - UTF8.Buf.contents b - in - let ccount = ref 0 in - UTF8.iter (fun c -> - let c = UCharExt.code c in - if (c >= 0xD800 && c <= 0xDFFF) || c >= 0x110000 then Error.abort "Invalid unicode char" p; - incr ccount; - if c > 0x10000 then incr ccount; - ) u8; - u8, !ccount - -let utf16_add buf c = - let add c = - Buffer.add_char buf (char_of_int (c land 0xFF)); - Buffer.add_char buf (char_of_int (c lsr 8)); - in - if c >= 0 && c < 0x10000 then begin - if c >= 0xD800 && c <= 0xDFFF then failwith ("Invalid unicode char " ^ string_of_int c); - add c; - end else if c < 0x110000 then begin - let c = c - 0x10000 in - add ((c asr 10) + 0xD800); - add ((c land 1023) + 0xDC00); - end else - failwith ("Invalid unicode char " ^ string_of_int c) - -let utf8_to_utf16 str zt = - let b = Buffer.create (String.length str * 2) in - (try UTF8.iter (fun c -> utf16_add b (UCharExt.code c)) str with Invalid_argument _ | UCharExt.Out_of_range -> ()); (* if malformed *) - if zt then utf16_add b 0; - Buffer.contents b - -let utf16_to_utf8 str = - let b = Buffer.create 0 in - let add c = Buffer.add_char b (char_of_int (c land 0xFF)) in - let get i = int_of_char (String.unsafe_get str i) in - let rec loop i = - if i >= String.length str then () - else begin - let c = get i in - if c < 0x80 then begin - add c; - loop (i + 2); - end else if c < 0x800 then begin - let c = c lor ((get (i + 1)) lsl 8) in - add c; - add (c lsr 8); - loop (i + 2); - end else - die "" __LOC__; - end - in - loop 0; - Buffer.contents b - let add_diagnostics_message ?(depth = 0) ?(code = None) com s p kind sev = if sev = MessageSeverity.Error then com.has_error <- true; let di = com.shared.shared_display_information in diff --git a/src/core/stringHelper.ml b/src/core/stringHelper.ml index ab6c57df5cd..8593ee57718 100644 --- a/src/core/stringHelper.ml +++ b/src/core/stringHelper.ml @@ -1,3 +1,6 @@ +open Globals +open Extlib_leftovers + let uppercase s = let bytes = Bytes.of_string s in Bytes.iteri @@ -57,4 +60,89 @@ let escape_res_name name allowed = else if List.mem chr allowed then Char.escaped chr else - "-x" ^ (string_of_int (Char.code chr))) name \ No newline at end of file + "-x" ^ (string_of_int (Char.code chr))) name + + +(* UTF8 *) + +let to_utf8 str p = + let u8 = try + UTF8.validate str; + str; + with + UTF8.Malformed_code -> + (* ISO to utf8 *) + let b = UTF8.Buf.create 0 in + String.iter (fun c -> UTF8.Buf.add_char b (UCharExt.of_char c)) str; + UTF8.Buf.contents b + in + let ccount = ref 0 in + UTF8.iter (fun c -> + let c = UCharExt.code c in + if (c >= 0xD800 && c <= 0xDFFF) || c >= 0x110000 then failwith "Invalid unicode char"; + incr ccount; + if c > 0x10000 then incr ccount; + ) u8; + u8, !ccount + +let utf16_add buf c = + let add c = + Buffer.add_char buf (char_of_int (c land 0xFF)); + Buffer.add_char buf (char_of_int (c lsr 8)); + in + if c >= 0 && c < 0x10000 then begin + if c >= 0xD800 && c <= 0xDFFF then failwith ("Invalid unicode char " ^ string_of_int c); + add c; + end else if c < 0x110000 then begin + let c = c - 0x10000 in + add ((c asr 10) + 0xD800); + add ((c land 1023) + 0xDC00); + end else + failwith ("Invalid unicode char " ^ string_of_int c) + +let utf8_to_utf16 str zt = + let b = Buffer.create (String.length str * 2) in + (try UTF8.iter (fun c -> utf16_add b (UCharExt.code c)) str with Invalid_argument _ | UCharExt.Out_of_range -> ()); (* if malformed *) + if zt then utf16_add b 0; + Buffer.contents b + +let utf16_to_utf8 str = + let b = Buffer.create 0 in + let add c = Buffer.add_char b (char_of_int (c land 0xFF)) in + let get i = int_of_char (String.unsafe_get str i) in + let rec loop i = + if i >= String.length str then () + else begin + let c = get i in + if c < 0x80 then begin + add c; + loop (i + 2); + end else if c < 0x800 then begin + let c = c lor ((get (i + 1)) lsl 8) in + add c; + add (c lsr 8); + loop (i + 2); + end else + die "" __LOC__; + end + in + loop 0; + Buffer.contents b + +let url_encode s add_char = + let hex = "0123456789ABCDEF" in + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' -> + add_char c + | _ -> + add_char '%'; + add_char (String.unsafe_get hex (int_of_char c lsr 4)); + add_char (String.unsafe_get hex (int_of_char c land 0xF)); + done + +let url_encode_s s = + let b = Buffer.create 0 in + url_encode s (Buffer.add_char b); + Buffer.contents b \ No newline at end of file diff --git a/src/generators/gctx.ml b/src/generators/gctx.ml index 62cd56b59f2..02aaaf0285f 100644 --- a/src/generators/gctx.ml +++ b/src/generators/gctx.ml @@ -4,9 +4,13 @@ open Type type t = { platform : platform; defines : Define.define; + class_path : string list; + run_command : string -> int; + run_command_args : string -> string list -> int; basic : basic_types; debug : bool; file : string; + version : int; features : (string,bool) Hashtbl.t; modules : Type.module_def list; main : Type.texpr option; @@ -16,6 +20,20 @@ type t = { native_libs : NativeLibraries.native_library_base list; } +let defined com s = + Define.defined com.defines s + +let defined_value com v = + Define.defined_value com.defines v + +let define_value com k v = + Define.define_value com.defines k v + +let defined_value_safe ?default com v = + match default with + | Some s -> Define.defined_value_safe ~default:s com.defines v + | None -> Define.defined_value_safe com.defines v + let raw_defined gctx v = Define.raw_defined gctx.defines v @@ -62,4 +80,9 @@ let get_entry_point gctx = in let e = Option.get gctx.main in (* must be present at this point *) (snd path, c, e) - ) gctx.main_class \ No newline at end of file + ) gctx.main_class + +let map_source_header com f = + match defined_value_safe com Define.SourceHeader with + | "" -> () + | s -> f s \ No newline at end of file diff --git a/src/generators/genhl.ml b/src/generators/genhl.ml index b00adbdf181..edd7048f5f3 100644 --- a/src/generators/genhl.ml +++ b/src/generators/genhl.ml @@ -24,7 +24,7 @@ open Globals open Ast open Type open Error -open Common +open Gctx open Hlcode (* compiler *) @@ -84,7 +84,7 @@ type constval = | CString of string type context = { - com : Common.context; + com : Gctx.t; cglobals : (string, ttype) lookup; cstrings : (string, string) lookup; cbytes : (bytes, bytes) lookup; @@ -322,7 +322,7 @@ let set_curpos ctx p = let make_debug ctx arr = let get_relative_path p = - match Common.defined ctx.com Common.Define.AbsolutePath with + match Gctx.defined ctx.com Define.AbsolutePath with | true -> if (Filename.is_relative p.pfile) then Filename.concat (Sys.getcwd()) p.pfile else p.pfile @@ -332,7 +332,7 @@ let make_debug ctx arr = let base = List.find (fun path -> let l = String.length path in len > l && String.sub p.pfile 0 l = path - ) ctx.com.Common.class_path in + ) ctx.com.Gctx.class_path in let l = String.length base in String.sub p.pfile l (len - l) with Not_found -> @@ -3389,7 +3389,7 @@ let generate_static ctx c f = | (Meta.HlNative,[(EConst(String(lib,_)),_)] ,_ ) :: _ -> add_native lib f.cf_name | (Meta.HlNative,[(EConst(Float(ver,_)),_)] ,_ ) :: _ -> - let cur_ver = (try Common.defined_value ctx.com Define.HlVer with Not_found -> "") in + let cur_ver = (try Gctx.defined_value ctx.com Define.HlVer with Not_found -> "") in if cur_ver < ver then let gen_content() = op ctx (OThrow (make_string ctx ("Requires compiling with -D hl-ver=" ^ ver ^ ".0 or higher") null_pos)); @@ -4054,7 +4054,7 @@ let create_context com is_macro dump = let ctx = { com = com; is_macro = is_macro; - optimize = not (Common.raw_defined com "hl_no_opt"); + optimize = not (Gctx.raw_defined com "hl_no_opt"); dump_out = if dump then Some (IO.output_channel (open_out_bin "dump/hlopt.txt")) else None; m = method_context 0 HVoid null_capture false; cints = new_lookup(); @@ -4173,8 +4173,8 @@ let make_context_sign com = let prev_sign = ref "" and prev_data = ref "" let generate com = - let dump = Common.defined com Define.Dump in - let hl_check = Common.raw_defined com "hl_check" in + let dump = Gctx.defined com Define.Dump in + let hl_check = Gctx.raw_defined com "hl_check" in let sign = make_context_sign com in if sign = !prev_sign && not dump && not hl_check then begin @@ -4194,7 +4194,7 @@ let generate com = Hlcode.dump (fun s -> output_string ch (s ^ "\n")) code; close_out ch; end; - (*if Common.raw_defined com "hl_dump_spec" then begin + (*if Gctx.raw_defined com "hl_dump_spec" then begin let ch = open_out_bin "dump/hlspec.txt" in let write s = output_string ch (s ^ "\n") in Array.iter (fun f -> @@ -4220,19 +4220,19 @@ let generate com = if Path.file_extension com.file = "c" then begin let gnames = Array.make (Array.length code.globals) "" in PMap.iter (fun n i -> gnames.(i) <- n) ctx.cglobals.map; - if not (Common.defined com Define.SourceHeader) then begin + if not (Gctx.defined com Define.SourceHeader) then begin let version_major = com.version / 1000 in let version_minor = (com.version mod 1000) / 100 in let version_revision = (com.version mod 100) in - Common.define_value com Define.SourceHeader (Printf.sprintf "Generated by HLC %d.%d.%d (HL v%d)" version_major version_minor version_revision code.version); + Gctx.define_value com Define.SourceHeader (Printf.sprintf "Generated by HLC %d.%d.%d (HL v%d)" version_major version_minor version_revision code.version); end; Hl2c.write_c com com.file code gnames; let t = Timer.timer ["nativecompile";"hl"] in - if not (Common.defined com Define.NoCompilation) && com.run_command_args "haxelib" ["run";"hashlink";"build";escape_command com.file] <> 0 then failwith "Build failed"; + if not (Gctx.defined com Define.NoCompilation) && com.run_command_args "haxelib" ["run";"hashlink";"build";escape_command com.file] <> 0 then failwith "Build failed"; t(); end else begin let ch = IO.output_string() in - write_code ch code (not (Common.raw_defined com "hl_no_debug")); + write_code ch code (not (Gctx.raw_defined com "hl_no_debug")); let str = IO.close_out ch in let ch = open_out_bin com.file in output_string ch str; @@ -4242,10 +4242,10 @@ let generate com = end; Hlopt.clean_cache(); t(); - if Common.raw_defined com "run" then begin + if Gctx.raw_defined com "run" then begin if com.run_command_args "haxelib" ["run";"hashlink";"run";escape_command com.file] <> 0 then failwith "Failed to run HL"; end; - if Common.defined com Define.Interp then + if Gctx.defined com Define.Interp then try let t = Timer.timer ["generate";"hl";"interp"] in let ctx = Hlinterp.create true in diff --git a/src/generators/genjs.ml b/src/generators/genjs.ml index 53fe22012f3..fa2adb04ebc 100644 --- a/src/generators/genjs.ml +++ b/src/generators/genjs.ml @@ -2006,7 +2006,7 @@ let generate com = | Some smap -> write_mappings ctx.com smap "file:///"; let basefile = Filename.basename com.file in - print ctx "\n//# sourceMappingURL=%s.map" (url_encode_s basefile); + print ctx "\n//# sourceMappingURL=%s.map" (StringHelper.url_encode_s basefile); | None -> try Sys.remove (com.file ^ ".map") with _ -> ()); flush ctx; Option.may (fun chan -> close_out chan) ctx.chan diff --git a/src/generators/hl2c.ml b/src/generators/hl2c.ml index 035b9838be5..b222c1248d9 100644 --- a/src/generators/hl2c.ml +++ b/src/generators/hl2c.ml @@ -78,7 +78,7 @@ type context = { mutable file_prefix : string; mutable fun_index : int; mutable type_module : (ttype, code_module) PMap.t; - gcon : Common.context; + gcon : Gctx.t; } let sprintf = Printf.sprintf @@ -345,7 +345,7 @@ let short_digest str = let open_file ctx file = if ctx.curfile <> "" then close_file ctx; if file <> "hlc.json" then - Codegen.map_source_header ctx.gcon (fun s -> define ctx (sprintf "// %s" s)); + Gctx.map_source_header ctx.gcon (fun s -> define ctx (sprintf "// %s" s)); ctx.curfile <- file; ctx.fun_index <- 0; ctx.file_prefix <- (short_digest file) ^ "_" @@ -1457,7 +1457,7 @@ let write_c com file (code:code) gnames = let bnames = Array.map (fun b -> "bytes$" ^ short_digest (Digest.to_hex (Digest.bytes b))) code.bytes in let ctx = { - version = com.Common.version; + version = com.Gctx.version; out = Buffer.create 1024; tabs = ""; hlcode = code; @@ -1572,7 +1572,7 @@ let write_c com file (code:code) gnames = in Array.iteri (fun i str -> if String.length str >= string_data_limit then begin - let s = Common.utf8_to_utf16 str true in + let s = StringHelper.utf8_to_utf16 str true in sline "// %s..." (String.escaped (String.sub str 0 (string_data_limit-4))); output ctx (Printf.sprintf "vbyte string$%s[] = {" (short_digest str)); output_bytes (output ctx) s; diff --git a/src/generators/hlinterp.ml b/src/generators/hlinterp.ml index 8c32aced375..ec20f8b048e 100644 --- a/src/generators/hlinterp.ml +++ b/src/generators/hlinterp.ml @@ -293,7 +293,7 @@ let fstr = function | FFun f -> "function@" ^ string_of_int f.findex | FNativeFun (s,_,_) -> "native[" ^ s ^ "]" -let caml_to_hl str = Common.utf8_to_utf16 str true +let caml_to_hl str = StringHelper.utf8_to_utf16 str true let hash ctx str = let h = hl_hash str in @@ -318,7 +318,7 @@ let utf16_iter f s = loop 0 let utf16_char buf c = - Common.utf16_add buf (int_of_char c) + StringHelper.utf16_add buf (int_of_char c) let hl_to_caml str = let utf16_eof s = @@ -1777,9 +1777,9 @@ let load_native ctx lib name t = if c >= int_of_char 'a' && c <= int_of_char 'z' then c + int_of_char 'A' - int_of_char 'a' else c in - Common.utf16_add buf c + StringHelper.utf16_add buf c ) (String.sub s (int pos) ((int len) lsl 1)); - Common.utf16_add buf 0; + StringHelper.utf16_add buf 0; VBytes (Buffer.contents buf) | _ -> Globals.die "" __LOC__) | "ucs2_lower" -> @@ -1791,9 +1791,9 @@ let load_native ctx lib name t = if c >= int_of_char 'A' && c <= int_of_char 'Z' then c + int_of_char 'a' - int_of_char 'A' else c in - Common.utf16_add buf c + StringHelper.utf16_add buf c ) (String.sub s (int pos) ((int len) lsl 1)); - Common.utf16_add buf 0; + StringHelper.utf16_add buf 0; VBytes (Buffer.contents buf) | _ -> Globals.die "" __LOC__) | "url_encode" -> @@ -1801,8 +1801,8 @@ let load_native ctx lib name t = | [VBytes s; VRef (r, HI32)] -> let s = hl_to_caml s in let buf = Buffer.create 0 in - Common.url_encode s (utf16_char buf); - Common.utf16_add buf 0; + StringHelper.url_encode s (utf16_char buf); + StringHelper.utf16_add buf 0; let str = Buffer.contents buf in set_ref r (to_int (String.length str lsr 1 - 1)); VBytes str diff --git a/src/macro/eval/evalStdLib.ml b/src/macro/eval/evalStdLib.ml index 7cdb911bb58..a69d09e7ecb 100644 --- a/src/macro/eval/evalStdLib.ml +++ b/src/macro/eval/evalStdLib.ml @@ -2440,7 +2440,7 @@ end module StdStringTools = struct let url_encode s = let b = Buffer.create 0 in - Common.url_encode s (Buffer.add_char b); + StringHelper.url_encode s (Buffer.add_char b); Buffer.contents b let fastCodeAt = StdString.charCodeAt