diff --git a/lib/irgen.ml b/lib/irgen.ml index ad47617..e54b6b3 100644 --- a/lib/irgen.ml +++ b/lib/irgen.ml @@ -31,6 +31,10 @@ and l_unit = L.void_type context and l_float = L.float_type context let l_str = L.pointer_type l_char +let l_strcat : L.lltype = L.function_type l_str [| l_str; l_str |] +let strcat_func the_module = L.declare_function "strcat" l_strcat the_module +let l_strcmp : L.lltype = L.function_type l_int [| l_str; l_str |] +let strcmp_func the_module = L.declare_function "strcmp" l_strcmp the_module let rec ltype_of_typ = function | RInt -> l_int @@ -292,74 +296,117 @@ let rec build_expr expr (vars : variable StringMap.t) var_types the_module build let typ = fst e1 in let se1 = build_expr e1 vars var_types the_module builder in let se2 = build_expr e2 vars var_types the_module builder in - let lval = - match typ with - | RInt -> - (match op with - | A.Add -> L.build_add - | A.Sub -> L.build_sub - | A.Mult -> L.build_mul - | A.Div -> L.build_sdiv - | A.Mod -> L.build_srem - | A.Equal -> L.build_icmp L.Icmp.Eq - | A.Neq -> L.build_icmp L.Icmp.Ne - | A.Less -> L.build_icmp L.Icmp.Slt - | A.Leq -> L.build_icmp L.Icmp.Sle - | A.Greater -> L.build_icmp L.Icmp.Sgt - | A.Geq -> L.build_icmp L.Icmp.Sge - | _ -> - failwith - (Printf.sprintf - "Integer binary operator %s not yet implemented" - (Utils.string_of_op op))) - | RFloat -> - (match op with - | A.Add -> L.build_fadd - | A.Sub -> L.build_fsub - | A.Mult -> L.build_fmul - | A.Div -> L.build_fdiv - | A.Mod -> L.build_frem - | A.Equal -> L.build_fcmp L.Fcmp.Oeq - | A.Neq -> L.build_fcmp L.Fcmp.One - | A.Less -> L.build_fcmp L.Fcmp.Olt - | A.Leq -> L.build_fcmp L.Fcmp.Ole - | A.Greater -> L.build_fcmp L.Fcmp.Ogt - | A.Geq -> L.build_fcmp L.Fcmp.Oge - | _ -> - failwith - (Printf.sprintf - "Float binary operator %s not yet implemented" - (Utils.string_of_op op))) - | RBool -> - (match op with - | A.And -> L.build_and - | A.Or -> L.build_or - | A.Equal -> L.build_icmp L.Icmp.Eq - | A.Neq -> L.build_icmp L.Icmp.Ne - | _ -> - failwith - (Printf.sprintf - "Boolean binary operator %s not yet implemented" - (Utils.string_of_op op))) - | REnumType _ -> - (match op with - | A.Equal -> L.build_icmp L.Icmp.Eq - | A.Neq -> L.build_icmp L.Icmp.Ne + (match typ with + | RString -> + (match op with + | A.Add -> + let len1 = L.build_call (strlen_func the_module) [| se1 |] "strlen1" builder in + let len2 = L.build_call (strlen_func the_module) [| se2 |] "strlen2" builder in + let total_len = L.build_add len1 len2 "total_len" builder in + let total_len_plus_one = + L.build_add total_len (L.const_int l_int 1) "total_len_plus_one" builder + in + let new_str = + L.build_array_alloca l_char total_len_plus_one "new_str" builder + in + let new_str_ptr = L.build_pointercast new_str l_str "new_str_ptr" builder in + ignore (L.build_store (L.const_int l_char 0) new_str_ptr builder); + ignore + (L.build_call + (strcat_func the_module) + [| new_str_ptr; se1 |] + "strcat1" + builder); + ignore + (L.build_call + (strcat_func the_module) + [| new_str_ptr; se2 |] + "strcat2" + builder); + new_str_ptr + | A.Equal -> + let cmp = + L.build_call (strcmp_func the_module) [| se1; se2 |] "strcmp" builder + in + L.build_icmp L.Icmp.Eq cmp (L.const_int l_int 0) "eq" builder + | A.Neq -> + let cmp = + L.build_call (strcmp_func the_module) [| se1; se2 |] "strcmp" builder + in + L.build_icmp L.Icmp.Ne cmp (L.const_int l_int 0) "neq" builder + | _ -> + failwith + (Printf.sprintf + "String binary operator %s not yet implemented" + (Utils.string_of_op op))) + | _ -> + let lval = + match typ with + | RInt -> + (match op with + | A.Add -> L.build_add + | A.Sub -> L.build_sub + | A.Mult -> L.build_mul + | A.Div -> L.build_sdiv + | A.Mod -> L.build_srem + | A.Equal -> L.build_icmp L.Icmp.Eq + | A.Neq -> L.build_icmp L.Icmp.Ne + | A.Less -> L.build_icmp L.Icmp.Slt + | A.Leq -> L.build_icmp L.Icmp.Sle + | A.Greater -> L.build_icmp L.Icmp.Sgt + | A.Geq -> L.build_icmp L.Icmp.Sge + | _ -> + failwith + (Printf.sprintf + "Integer binary operator %s not yet implemented" + (Utils.string_of_op op))) + | RFloat -> + (match op with + | A.Add -> L.build_fadd + | A.Sub -> L.build_fsub + | A.Mult -> L.build_fmul + | A.Div -> L.build_fdiv + | A.Mod -> L.build_frem + | A.Equal -> L.build_fcmp L.Fcmp.Oeq + | A.Neq -> L.build_fcmp L.Fcmp.One + | A.Less -> L.build_fcmp L.Fcmp.Olt + | A.Leq -> L.build_fcmp L.Fcmp.Ole + | A.Greater -> L.build_fcmp L.Fcmp.Ogt + | A.Geq -> L.build_fcmp L.Fcmp.Oge + | _ -> + failwith + (Printf.sprintf + "Float binary operator %s not yet implemented" + (Utils.string_of_op op))) + | RBool -> + (match op with + | A.And -> L.build_and + | A.Or -> L.build_or + | A.Equal -> L.build_icmp L.Icmp.Eq + | A.Neq -> L.build_icmp L.Icmp.Ne + | _ -> + failwith + (Printf.sprintf + "Boolean binary operator %s not yet implemented" + (Utils.string_of_op op))) + | REnumType _ -> + (match op with + | A.Equal -> L.build_icmp L.Icmp.Eq + | A.Neq -> L.build_icmp L.Icmp.Ne + | _ -> + failwith + (Printf.sprintf + "Internal Compiler Error: Operator %s on EnumType %s reached IRgen." + (Utils.string_of_op op) + (Utils.string_of_resolved_type typ))) | _ -> failwith (Printf.sprintf - "Internal Compiler Error: Operator %s on EnumType %s reached IRgen." + "Binary operator %s not yet implemented for type %s" (Utils.string_of_op op) - (Utils.string_of_resolved_type typ))) - | RString -> failwith "GOT A STRING\n" - | _ -> - failwith - (Printf.sprintf - "Binary operator %s not yet implemented for type %s" - (Utils.string_of_op op) - (Utils.string_of_resolved_type typ)) - in - lval se1 se2 ("tmp_" ^ Utils.string_of_resolved_type typ) builder + (Utils.string_of_resolved_type typ)) + in + lval se1 se2 "tmp" builder) | SUDTInstance (typename, fields) -> let struct_type = Hashtbl.find udt_structs typename in let field_indices = Hashtbl.find udt_field_indices typename in diff --git a/lib/semant.ml b/lib/semant.ml index 30ef5b6..7a38d44 100644 --- a/lib/semant.ml +++ b/lib/semant.ml @@ -154,6 +154,7 @@ and get_binop_return_type expr t1 binop t2 = (match t1, t2 with | RInt, RInt -> RInt | RFloat, RFloat -> RFloat + | RString, RString -> RString | _, _ -> raise (Failure (format_binop_error expr t1 t2))) | Equal | Neq -> (match t1, t2 with diff --git a/test/ir/test_string.ml b/test/ir/test_string.ml index eb2643c..58e7cfe 100644 --- a/test/ir/test_string.ml +++ b/test/ir/test_string.ml @@ -63,6 +63,86 @@ let tests = }\n" in assert_equal expected actual ~printer) + ; ("concat_string" + >:: fun _ -> + let sast = + get_sast + "fun function() -> () {let a := \"hello\"; let b := \" World\"; a + b; }" + in + let mdl = Irgen.translate sast in + let actual = L.string_of_llmodule mdl in + let expected = + "; ModuleID = 'Fly'\n\ + source_filename = \"Fly\"\n\n\ + @str = private unnamed_addr constant [6 x i8] c\"hello\\00\", align 1\n\ + @str.1 = private unnamed_addr constant [7 x i8] c\" World\\00\", align 1\n\n\ + define void @function() {\n\ + entry:\n\ + \ %a = alloca i8*, align 8\n\ + \ store i8* getelementptr inbounds ([6 x i8], [6 x i8]* @str, i32 0, i32 \ + 0), i8** %a, align 8\n\ + \ %b = alloca i8*, align 8\n\ + \ store i8* getelementptr inbounds ([7 x i8], [7 x i8]* @str.1, i32 0, i32 \ + 0), i8** %b, align 8\n\ + \ %a1 = load i8*, i8** %a, align 8\n\ + \ %b2 = load i8*, i8** %b, align 8\n\ + \ %strlen1 = call i32 @strlen(i8* %a1)\n\ + \ %strlen2 = call i32 @strlen(i8* %b2)\n\ + \ %total_len = add i32 %strlen1, %strlen2\n\ + \ %total_len_plus_one = add i32 %total_len, 1\n\ + \ %new_str = alloca i8, i32 %total_len_plus_one, align 1\n\ + \ store i8 0, i8* %new_str, align 1\n\ + \ %strcat1 = call i8* @strcat(i8* %new_str, i8* %a1)\n\ + \ %strcat2 = call i8* @strcat(i8* %new_str, i8* %b2)\n\ + \ ret void\n\ + }\n\n\ + declare i32 @strlen(i8*)\n\n\ + declare i8* @strcat(i8*, i8*)\n" + in + assert_equal expected actual ~printer) + ; ("print_concat_string" + >:: fun _ -> + let sast = + get_sast + "fun function() -> () {let a := \"hello\"; let b := \" World\"; print(a + \ + b); }" + in + let mdl = Irgen.translate sast in + let actual = L.string_of_llmodule mdl in + let expected = + "; ModuleID = 'Fly'\n\ + source_filename = \"Fly\"\n\n\ + @str = private unnamed_addr constant [6 x i8] c\"hello\\00\", align 1\n\ + @str.1 = private unnamed_addr constant [7 x i8] c\" World\\00\", align 1\n\ + @str_fmt = private unnamed_addr constant [4 x i8] c\"%s\\0A\\00\", align 1\n\n\ + define void @function() {\n\ + entry:\n\ + \ %a = alloca i8*, align 8\n\ + \ store i8* getelementptr inbounds ([6 x i8], [6 x i8]* @str, i32 0, i32 \ + 0), i8** %a, align 8\n\ + \ %b = alloca i8*, align 8\n\ + \ store i8* getelementptr inbounds ([7 x i8], [7 x i8]* @str.1, i32 0, i32 \ + 0), i8** %b, align 8\n\ + \ %a1 = load i8*, i8** %a, align 8\n\ + \ %b2 = load i8*, i8** %b, align 8\n\ + \ %strlen1 = call i32 @strlen(i8* %a1)\n\ + \ %strlen2 = call i32 @strlen(i8* %b2)\n\ + \ %total_len = add i32 %strlen1, %strlen2\n\ + \ %total_len_plus_one = add i32 %total_len, 1\n\ + \ %new_str = alloca i8, i32 %total_len_plus_one, align 1\n\ + \ store i8 0, i8* %new_str, align 1\n\ + \ %strcat1 = call i8* @strcat(i8* %new_str, i8* %a1)\n\ + \ %strcat2 = call i8* @strcat(i8* %new_str, i8* %b2)\n\ + \ %call_printf = call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([4 \ + x i8], [4 x i8]* @str_fmt, i32 0, i32 0), i8* %new_str)\n\ + \ ret void\n\ + }\n\n\ + declare i32 @strlen(i8*)\n\n\ + declare i8* @strcat(i8*, i8*)\n\n\ + declare i32 @printf(i8*, ...)\n" + in + _write_to_file actual "actual.out"; + assert_equal expected actual ~printer) ] ;; diff --git a/test/sample_programs/test_concat_string.fly b/test/sample_programs/test_concat_string.fly new file mode 100644 index 0000000..5c58932 --- /dev/null +++ b/test/sample_programs/test_concat_string.fly @@ -0,0 +1,5 @@ +fun main() -> () { + let a := "hello"; + let b := " World"; + print(a + b); +}