From 07651e8f984560f3ab3cba4fb1740aee7223c76e Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 24 Mar 2025 14:24:16 +0300 Subject: [PATCH 01/84] feat: current parser implementation Signed-off-by: Dmitri --- CSharpStrange/CSharpStrange.opam | 36 +++ CSharpStrange/bin/ast_fact.ml | 40 +++ CSharpStrange/dune-project | 35 +++ CSharpStrange/lib/ast.ml | 133 ++++++++++ CSharpStrange/lib/dune | 9 + CSharpStrange/lib/parser.ml | 377 ++++++++++++++++++++++++++++ CSharpStrange/tests/ast_fact.t | 23 ++ CSharpStrange/tests/dune | 16 ++ CSharpStrange/tests/parser_tests.ml | 259 +++++++++++++++++++ ZarubinAlexey/.ocamlformat | 2 +- 10 files changed, 929 insertions(+), 1 deletion(-) create mode 100644 CSharpStrange/CSharpStrange.opam create mode 100644 CSharpStrange/bin/ast_fact.ml create mode 100644 CSharpStrange/dune-project create mode 100644 CSharpStrange/lib/ast.ml create mode 100644 CSharpStrange/lib/dune create mode 100644 CSharpStrange/lib/parser.ml create mode 100644 CSharpStrange/tests/ast_fact.t create mode 100644 CSharpStrange/tests/dune create mode 100644 CSharpStrange/tests/parser_tests.ml diff --git a/CSharpStrange/CSharpStrange.opam b/CSharpStrange/CSharpStrange.opam new file mode 100644 index 00000000..7e5c764d --- /dev/null +++ b/CSharpStrange/CSharpStrange.opam @@ -0,0 +1,36 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.1" +synopsis: "An interpreter for strange subset of C# language" +description: + "An interpreter for subset of C# language with async/await and LINQ (and some other stuff which will be added later)" +maintainer: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] +authors: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] +license: "LGPL-3.0-or-later" +homepage: "https://github.com/f1i3g3/fp2024" +bug-reports: "https://github.com/f1i3g3/fp2024" +depends: [ + "dune" {>= "3.7"} + "angstrom" + "ppx_inline_test" {with-test} + "ppx_expect" + "ppx_deriving" + "bisect_ppx" + "odoc" {with-doc} + "ocamlformat" {build} + "base" +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] diff --git a/CSharpStrange/bin/ast_fact.ml b/CSharpStrange/bin/ast_fact.ml new file mode 100644 index 00000000..6e5e3248 --- /dev/null +++ b/CSharpStrange/bin/ast_fact.ml @@ -0,0 +1,40 @@ +(** Copyright 2024, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open C_sharp_strange_lib.Ast +open C_sharp_strange_lib.Parser +open Angstrom +open Printf + +let fact_ast = + Program + (Class + ( [ MPublic ] + , Id "Program" + , [ Method ([ MPublic; MStatic ], TypeBase TypeVoid, Id "Main", [], SBlock []) + ; Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "Factorial" + , [ TypeBase TypeInt, "n" ] + , SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) + , SReturn (Some (EValue (ValInt 1))) + , Some + (SReturn + (Some + (EBinOp + ( OpMul + , EId (Id "n") + , EFuncCall + ( EId (Id "Factorial") + , [ EBinOp + (OpSub, EId (Id "n"), EValue (ValInt 1)) + ] ) )))) ) + ] ) + ] )) +;; + +let () = print_endline (show_program fact_ast) (* AST print test *) diff --git a/CSharpStrange/dune-project b/CSharpStrange/dune-project new file mode 100644 index 00000000..dba4e1cb --- /dev/null +++ b/CSharpStrange/dune-project @@ -0,0 +1,35 @@ +(lang dune 3.7) + +(generate_opam_files true) + +(cram enable) + +(license LGPL-3.0-or-later) + +(authors "Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com") + +(maintainers "Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com") + +(bug_reports "https://github.com/f1i3g3/fp2024") + +(homepage "https://github.com/f1i3g3/fp2024") + +(package + (name CSharpStrange) + (synopsis "An interpreter for strange subset of C# language") + (description + "An interpreter for subset of C# language with async/await and LINQ (and some other stuff which will be added later)") + ; TODO: actual documentation (documentation "https://kakadu.github.io/fp2024/docs/Lambda") + (version 0.1) + (depends + dune + angstrom + (ppx_inline_test :with-test) + ppx_expect + ppx_deriving + bisect_ppx + (odoc :with-doc) + (ocamlformat :build) + base + ; After adding dependencies to 'dune' files add the same dependecies here too + )) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml new file mode 100644 index 00000000..4320dd4a --- /dev/null +++ b/CSharpStrange/lib/ast.ml @@ -0,0 +1,133 @@ +(** Copyright 2024, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +(** Values types *) +type val_type = + | ValInt of int (** Int value *) + | ValChar of char (** Char value *) + | ValNull (** Null *) + | ValBool of bool (** Bool value *) + | ValArray of val_type list (** TODO: array value *) + | ValString of string (** TODO: string value *) +[@@deriving eq, show { with_path = false }] + +(** Identidicator *) +type ident = Id of string [@@deriving eq, show { with_path = false }] + +(** Basic types declarations *) +type base_type = + | TypeInt (** Declaration of int *) + | TypeChar (** Declaration of char *) + | TypeBool (** Declaration of bool *) + | TypeVoid (** Declaration of void TODO: remove by specification?? *) +[@@deriving eq, show { with_path = false }] +(* TODO: declaration of strings?? *) + +(** Type delcaration *) +type _type = + | TypeBase of base_type (** Declaration of basic type *) + | TypeArray of base_type (** Declaration of array of basic type TODO: rank *) + | TypeString (** Declaration of string TODO*) +[@@deriving eq, show { with_path = false }] +(* TODO: records for arrays?? *) +(* TODO: strings "" *) + +(** Variable *) +type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] + +(** Modifiers *) +type modifier = + | MPublic (** Public modifier, used for main() method only *) + | MStatic (** Static modifier, used for main() method only *) + | MConst (** Const modifier *) (* TODO *) + | MAsync (** Async modifier *) +[@@deriving eq, show { with_path = false }] + +type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] +and params = Params of var_decl list [@@deriving eq, show { with_path = false }] + +(** Binary operations *) +type bin_op = + | OpAdd (** Sum: a [+] b *) + | OpSub (** a [-] b *) + | OpMul (** a [*] b *) + | OpDiv (** a [/] b in integers *) + | OpMod (** a [%] b *) + | OpEqual (** a [==] b *) + | OpNonEqual (** a [!=] b *) + | OpLess (** a [<] b *) + | OpMore (** a [>] b *) + | OpLessEqual (** a [<=] b *) + | OpMoreEqual (** a [>=] b *) + | OpAnd (** a [&&] b *) + | OpOr (** a [||] b *) + | OpAssign (** a [=] b *) +[@@deriving eq, show { with_path = false }] + +(** Unary operations *) +type un_op = + | OpInc (** [++] a or [++] a *) (* TODO remove?? *) + | OpDec (** [--] a or [--] a *) (* TODO remove?? *) + | OpNot (** [!] a *) + | OpNew (** [new] a *) +[@@deriving eq, show { with_path = false }] + +(** Language expressions *) +type expr = + | EValue of val_type (** Some value *) + | EBinOp of bin_op * expr * expr (** Binary operation *) + | EUnOp of un_op * expr (** Unary operation *) + | EConst of val_type (** Const expression TODO change for modifiers?? *) + | EId of ident (** Identificator expression *) + | EArrayAccess of expr * expr (** Array access: a = arr[i] *) + | EFuncCall of expr * expr list + (** Call of function: name(arguments) TODO: Program.x() *) + | ELambda of expr * stmt (** Lambda expressions *) + | EAwait of expr (** Await expression *) + | ELinqQuery of linq_query (** from identifier in expr select expr *) +[@@deriving eq, show { with_path = false }] + +(** Language statements *) +and stmt = + | SFor of stmt option * expr option * expr option * stmt + (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) + | SIf of expr * stmt * stmt option + (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) + | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) + | SReturn of expr option (** Return: return (a) *) + | SBlock of stmt list (** Block of statements: \{ a \}; could be empty: \{\} *) + | SBreak (** Cycle break *) + | SContinue (** Cycle continue *) + | SExpr of expr (** Another expression *) + | SDecl of var_decl * expr option (** Var declaration *) +[@@deriving eq, show { with_path = false }] + +(** From clauses *) +and from_clause = FromClause of string * ident +[@@deriving eq, show { with_path = false }] + +(** Select clause *) +and select_clause = SelectClause of expr [@@deriving eq, show { with_path = false }] + +(** LINQ query *) +and linq_query = + | SQuery of from_clause * select_clause (** from identifier in identifier select expr *) +[@@deriving eq, show { with_path = false }] + +(** C Sharp class fields *) +type field = + | VarField of modifier list * _type * ident * expr + (** Class field - always initialized *) + | Method of modifier list * _type * ident * params * stmt (** Class method *) +[@@deriving eq, show { with_path = false }] + +(** C Sharp class *) +type c_sharp_class = + | Class of modifier list * ident * field list (** Basic class (Program) name *) +[@@deriving eq, show { with_path = false }] + +(** Program AST *) +type program = Program of c_sharp_class [@@deriving eq, show { with_path = false }] + +(* TODO: read specification!! + write factorial parser from scratch *) diff --git a/CSharpStrange/lib/dune b/CSharpStrange/lib/dune new file mode 100644 index 00000000..03116c1d --- /dev/null +++ b/CSharpStrange/lib/dune @@ -0,0 +1,9 @@ +(library + (name c_sharp_strange_lib) + (public_name CSharpStrange.Lib) + (modules Ast Parser Prettyprinter Mlparser) + (libraries angstrom base) + (preprocess + (pps ppx_deriving.show ppx_deriving.eq ppx_expect ppx_inline_test)) + (instrumentation + (backend bisect_ppx))) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml new file mode 100644 index 00000000..de13e3c0 --- /dev/null +++ b/CSharpStrange/lib/parser.ml @@ -0,0 +1,377 @@ +open Ast +open Angstrom +open Base + +(* Chain functions *) +let chainl0 expr op = op >>= (fun op1 -> expr >>| fun exp -> op1 exp) <|> expr + +let chainl1 expr op = + let rec pars e1 = lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 in + expr >>= fun init -> pars init +;; + +let chainr1 expr op = + fix (fun x -> + lift2 (fun op1 e2 -> op1 e2) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) +;; + +(* Special functions *) +let reserved = + [ "true" + ; "false" + ; "if" + ; "else" + ; "while" + ; "public" + ; "static" + ; "const" + ; "void" + ; "string" + ; "char" + ; "int" + ; "bool" + ; "for" + ; "null" + ; "new" + ; "return" + ; "break" + ; "continue" + ; "class" + ; "async" + ; "await" + ; "select" + ; "from" + ] +;; + +let in_reserved t = List.mem reserved t ~equal:String.equal + +let is_space = function + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false +;; + +let is_token_sym = function + | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '_' -> true + | _ -> false +;; + +let skip_spaces = skip_while is_space +let parens p = skip_spaces *> char '(' *> p <* skip_spaces <* char ')' +let braces p = skip_spaces *> char '{' *> p <* skip_spaces <* char '}' +let brackets p = skip_spaces *> char '[' *> p <* skip_spaces <* char ']' +let skip_semicolons = fix (fun f -> skip_spaces *> char ';' *> f <|> return "") +let skip_semicolons1 = skip_spaces *> char ';' *> skip_semicolons + +(* Values *) + +let parse_int = + take_while1 Char.is_digit + >>= fun num -> return @@ ValInt (int_of_string num) <|> fail "Not an int" +;; + +let parse_char = + char '\'' *> any_char + <* char '\'' + >>= (fun c -> return @@ ValChar c) + <|> fail "Not a char" +;; + +let parse_bool = + choice + [ string "true" *> return (ValBool true); string "false" *> return (ValBool false) ] + <|> fail "Not a bool" +;; + +let parse_val_string = + char '\"' + *> take_till (function + | '\"' -> true + | _ -> false) + <* char '\"' + >>= (fun s -> return @@ ValString s) + <|> fail "Not a string" +;; + +let parse_null = string "null" *> return ValNull <|> fail "Not a null" + +(* TODO: parse_array *) +let parse_array = fail "Not implemented" +let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x + +let parse_value = + choice + [ val_to_expr parse_bool + ; val_to_expr parse_char + ; val_to_expr parse_int + ; val_to_expr parse_null + ; val_to_expr parse_val_string + ] +;; + +let parse_id = + take_while is_token_sym + >>= fun str -> + match not (String.is_empty str || in_reserved str || Char.is_digit str.[0]) with + | true -> return (Id str) + | _ -> fail "Not an identifier" +;; + +(* Modifiers *) + +let parse_modifiers = + many + (choice + [ string "public" *> skip_spaces *> return MPublic + ; string "static" *> skip_spaces *> return MStatic + ; string "const" *> skip_spaces *> return MConst + ; string "async" *> skip_spaces *> return MAsync + ]) +;; + +(* Type words *) +let parse_type_word = + (* TODO REMOVE AST!!!! *) + take_while is_token_sym + >>= function + | "int" -> return @@ Ast.TypeBase Ast.TypeInt + | "char" -> return @@ Ast.TypeBase Ast.TypeChar + | "bool" -> return @@ Ast.TypeBase Ast.TypeBool + | "string" -> return @@ Ast.TypeString + | _ -> fail "Wrong type word" +;; + +(* Expressions *) + +(* Variables && functions *) +let parse_var_type = + parse_type_word >>= fun x -> return (TypeVar x) <|> fail "Incorrect type" +;; + +let parse_var = + let parse_decl_id typ_ = + char ' ' *> skip_spaces *> parse_id >>| fun id -> Var (typ_, id) + in + skip_spaces *> parse_var_type >>= parse_decl_id +;; + +let parse_id_expr = skip_spaces *> parse_id >>= fun x -> return @@ EId x +let parse_call_id = parse_id_expr (* TODO Program.x *) + +let parse_args_list arg = + let args = arg <* skip_spaces *> char ',' <|> arg in + parens @@ many args +;; + +let parse_call_args id arg = + parse_args_list arg >>= fun args -> return @@ EFuncCall (id, args) +;; + +let parse_call_expr arg = parse_call_id >>= fun id -> parse_call_args id arg + +(* Operations *) +let parse_op op typ = skip_spaces *> string op *> return typ + +(* Binary operations *) +let parse_bin_op op typ = parse_op op typ >>| fun t a b -> EBinOp (t, a, b) +let ( ^+^ ) = parse_bin_op "+" OpAdd +let ( ^-^ ) = parse_bin_op "-" OpSub +let ( ^*^ ) = parse_bin_op "*" OpMul +let ( ^/^ ) = parse_bin_op "/" OpDiv +let ( ^%^ ) = parse_bin_op "%" OpMod +let ( ^==^ ) = parse_bin_op "==" OpEqual +let ( ^!=^ ) = parse_bin_op "!=" OpNonEqual +let ( ^<^ ) = parse_bin_op "<" OpLess +let ( ^>^ ) = parse_bin_op ">" OpMore +let ( ^<=^ ) = parse_bin_op "<=" OpLessEqual +let ( ^>=^ ) = parse_bin_op ">=" OpMoreEqual +let ( ^&&^ ) = parse_bin_op "&&" OpAnd +let ( ^||^ ) = parse_bin_op "||" OpOr +let ( ^=^ ) = parse_bin_op "=" OpAssign + +(* Unary operations *) +let parse_un_op op typ = parse_op op typ >>| fun t a -> EUnOp (t, a) + +(*TODO: check for increment/decrement ??*) +let ( ^!^ ) = parse_un_op "!" OpNot +let parse_new = parse_un_op "new" OpNew + +let parse_ops = + fix (fun expr -> + let lv1 = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in + let lv2 = chainl0 lv1 (choice [ parse_new; ( ^!^ ) ]) in + let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in + let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in + let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in + let lv6 = chainl1 lv5 (choice [ ( ^==^ ); ( ^!=^ ) ]) in + let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in + let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in + chainr1 lv8 (choice [ ( ^=^ ) ])) +;; + +let parse_assign = lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops + +(* Statements + LINQ *) + +let get_opt p = p >>| fun x -> Some x + +let parse_decl = + lift2 + (fun dcl e -> SDecl (dcl, e)) + parse_var + (option None (skip_spaces *> char '=' *> parse_ops >>| fun e -> Some e)) +;; + +(* TODO: check other return "" *) +let expr_to_stmt expr = expr >>| fun x -> SExpr x +let parse_stmt_ops = expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] + +(* TODO: Check block contains (esp. other ifs) *) +let parse_if_else f_if_body = + let parse_if_cond = string "if" *> skip_spaces *> parens parse_ops in + let parse_else_cond ifls body = + skip_spaces + *> (get_opt @@ (string "else" *> skip_spaces *> choice [ ifls; body ]) <|> return None) + in + fix (fun ifls -> + let parse_body = f_if_body <|> (parse_stmt_ops <* skip_semicolons1) in + let parse_else_body = parse_else_cond ifls parse_body in + lift3 + (fun cond if_body else_body -> SIf (cond, if_body, else_body)) + parse_if_cond + parse_body + parse_else_body) +;; + +(* TODO: Check block contains *) +let parse_for body = + let expr_to_option_stmt expr = get_opt @@ expr_to_stmt expr in + let p_body = body <|> (parse_stmt_ops <* skip_semicolons1) in + let p_for_init = + option None (get_opt parse_decl <|> expr_to_option_stmt parse_assign) + in + let p_for_expr = option None (get_opt parse_ops) in + let p_for = + lift2 + (fun (f_init_p, f_cond_p, f_iter_p) f_body -> + SFor (f_init_p, f_cond_p, f_iter_p, f_body)) + (parens + @@ lift3 + (fun init cond incr -> init, cond, incr) + (p_for_init <* skip_spaces <* char ';') + (p_for_expr <* skip_spaces <* char ';') + p_for_expr) + p_body + in + string "for" *> p_for +;; + +let parse_while body = + let p_body = body <|> skip_semicolons1 *> parse_stmt_ops in + let p_cond = parens parse_ops in + let p_while = string "while" *> skip_spaces *> p_cond in + lift2 (fun cond body -> SWhile (cond, body)) p_while p_body +;; + +let parse_return = + lift2 + (fun _ expr -> SReturn expr) + (string "return") + (parse_ops >>= (fun ret -> return (Some ret)) <|> return None) +;; + +let parse_break = skip_spaces *> string "break" *> return SBreak +let parse_continue = skip_spaces *> string "continue" *> return SContinue + +(* {{}} TODO ??*) + +let parse_block = + fix (fun block -> + let sc p = p <* skip_semicolons1 in + let op_sc p = p <* skip_semicolons in + let body_step = + choice + ?failure_msg:(Some "Error in some block sentence") + [ sc parse_decl + ; sc parse_break + ; sc parse_continue + ; sc parse_return + ; sc parse_stmt_ops + ; op_sc @@ parse_if_else block + ; op_sc @@ parse_for block + ; op_sc @@ parse_while block + ] + in + braces (skip_semicolons *> many (skip_spaces *> body_step)) + >>= fun stmt_lst -> return @@ SBlock stmt_lst) +;; + +(* Program class functions *) +(* TODO - tests!! *) + +let parse_field_sign = + let f_value = skip_spaces *> char '=' *> get_opt parse_ops in + lift4 + (fun f_modif f_type f_id f_val -> f_modif, f_type, f_id, f_val) + (option None (skip_spaces *> get_opt parse_modifiers)) + (skip_spaces *> parse_var_type) + (skip_spaces *> parse_id) + (option None f_value) + <* skip_semicolons1 +;; + +let parse_method_type = + (* TODO Fix!! *) + choice + [ (parse_type_word >>= fun x -> return @@ x) + ; (take_while is_token_sym + >>= fun x -> + if String.( = ) x "void" then return @@ TypeBase TypeVoid else fail "Not a type") + ] +;; + +let parse_method_sign = + let parse_args = + parens @@ many @@ (skip_spaces *> parse_var <* skip_spaces <* char ',') + >>= fun exp -> return (Params exp) + in + lift4 + (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) + (skip_spaces *> parse_modifiers) + (skip_spaces *> parse_method_type) + (skip_spaces *> parse_id) + parse_args +;; + +let parse_method_member = + lift2 (fun (mds, t, id, ps) bd -> Method (mds, t, id, ps, bd)) parse_method_sign parse_block +;; + +let parse_field_member = parse_field_sign >>| fun (a, b, c, d) -> VarField (a, b, c, d) + +let parse_class_members = + let member = choice [ parse_method_member; parse_field_member ] in + braces @@ many member +;; + +let parse_one_class1 = + let class_id = skip_spaces *> string "class" *> skip_spaces *> parse_id in + lift3 + (fun cl_modif cl_id cl_membs -> Class (cl_modif, cl_id, cl_membs)) + (skip_spaces *> parse_modifiers) + class_id + parse_class_members +;; + +let parse_one_class = return (Class ([], Id "Not implemented", [])) +let parse_prog : program t = parse_one_class <* skip_spaces >>| fun prog -> Program prog + +(* Main functions *) + +let parse_option p str = + match parse_string p ~consume:Angstrom.Consume.All str with + | Ok x -> Some x + | Error _ -> None +;; + +let apply_parser parser = parse_string ~consume:Consume.All parser diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange/tests/ast_fact.t new file mode 100644 index 00000000..682634de --- /dev/null +++ b/CSharpStrange/tests/ast_fact.t @@ -0,0 +1,23 @@ + $ ../bin/ast_fact.exe + (Program + (Class ([MPublic], (Id "Program"), + [(Method ([MPublic; MStatic], (TypeBase TypeVoid), (Id "Main"), + [], (SBlock []))); + (Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), + [((TypeBase TypeInt), "n")], + (SBlock + [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), + (SReturn (Some (EValue (ValInt 1)))), + (Some (SReturn + (Some (EBinOp (OpMul, (EId (Id "n")), + (EFuncCall ((EId (Id "Factorial")), + [(EBinOp (OpSub, (EId (Id "n")), + (EValue (ValInt 1)))) + ] + )) + ))))) + )) + ]) + )) + ] + ))) diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune new file mode 100644 index 00000000..30003bcf --- /dev/null +++ b/CSharpStrange/tests/dune @@ -0,0 +1,16 @@ +(library + (name tests) + (public_name CSharpStrange.Lib.Tests) + (modules Parser_tests) + (libraries angstrom c_sharp_strange_lib) + (inline_tests) + (instrumentation + (backend bisect_ppx)) + (preprocess + (pps ppx_expect))) + +(cram + (applies_to ast_fact) + (deps + ../bin/ast_fact.exe + ../bin/factorial.cs)) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml new file mode 100644 index 00000000..c7fb8e97 --- /dev/null +++ b/CSharpStrange/tests/parser_tests.ml @@ -0,0 +1,259 @@ +open C_sharp_strange_lib.Ast +open C_sharp_strange_lib.Parser +open C_sharp_strange_lib.Prettyprinter + +let%test "Parse one integer" = apply_parser parse_int {|1|} = Ok (ValInt 1) +let%test "Parse one char" = apply_parser parse_char {|'c'|} = Ok (ValChar 'c') +let%test "Parse true" = apply_parser parse_bool {|true|} = Ok (ValBool true) +let%test "Parse false" = apply_parser parse_bool {|false|} = Ok (ValBool false) + +let%test "Parse string" = + apply_parser parse_val_string {|"sample"|} = Ok (ValString "sample") +;; + +let%test "Parse parens" = apply_parser (parens parse_int) {|(1)|} = Ok (ValInt 1) +let%test "Parse braces" = apply_parser (braces parse_int) {|{1}|} = Ok (ValInt 1) +let%test "Parse brackets" = apply_parser (brackets parse_int) {|[1]|} = Ok (ValInt 1) +let%test "Parse one modifier 1" = apply_parser parse_modifiers {|static|} = Ok [ MStatic ] +let%test "Parse one modifier 2" = apply_parser parse_modifiers {|public|} = Ok [ MPublic ] + +let%test "Parse two modifiers" = + apply_parser parse_modifiers {|const async|} = Ok [ MConst; MAsync ] +;; + +let%test "Parse add 1" = + apply_parser parse_ops {| 1 + 2|} + = Ok (EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2))) +;; + +let%test "Parse add 2" = + apply_parser parse_ops {| a + b|} = Ok (EBinOp (OpAdd, EId (Id "a"), EId (Id "b"))) +;; + +let%test "Parse many adds" = + apply_parser parse_ops {| 1 + 2 + 3|} + = Ok + (EBinOp + (OpAdd, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; + +let%test "Parse adds with mul 1" = + apply_parser parse_ops {|1 + 2 * 3|} + = Ok + (EBinOp + (OpAdd, EValue (ValInt 1), EBinOp (OpMul, EValue (ValInt 2), EValue (ValInt 3)))) +;; + +let%test "Parse adds with mul 2" = + apply_parser parse_ops {| (1 + 2 ) * 3|} + = Ok + (EBinOp + (OpMul, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; + +let%test "Parse div with mod" = + apply_parser parse_ops {| 1 / 2 % 3|} + = Ok + (EBinOp + (OpMod, EBinOp (OpDiv, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; + +let%test "Parse div with mod" = + apply_parser parse_ops {| 1 - 2 / 3 + 4|} + = Ok + (EBinOp + ( OpAdd + , EBinOp + ( OpSub + , EValue (ValInt 1) + , EBinOp (OpDiv, EValue (ValInt 2), EValue (ValInt 3)) ) + , EValue (ValInt 4) )) +;; + +let%test "Parse simple boolean expression" = + apply_parser parse_ops {| ( 1 + 2 == 3 + 4 )|} + = Ok + (EBinOp + ( OpEqual + , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) + , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) )) +;; + +let%test "Parse complex boolean expression" = + apply_parser parse_ops {|( 1 + 2 < 3 + 4) && (5 == 8)|} + = Ok + (EBinOp + ( OpAnd + , EBinOp + ( OpLess + , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) + , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) ) + , EBinOp (OpEqual, EValue (ValInt 5), EValue (ValInt 8)) )) +;; + +let%test "Parse ident expr" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) +let%test "Parse id in expressions 1" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) + +let%test "Parse id in expressions 2" = + apply_parser parse_ops {|x + 1|} = Ok (EBinOp (OpAdd, EId (Id "x"), EValue (ValInt 1))) +;; + +let%test "Parse var declaration 1" = + apply_parser parse_decl {|int x|} + = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), None)) +;; + +let%test "Parse var declaration 2" = + apply_parser parse_decl {|int x = 1|} + = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1)))) +;; + +let%test "Parse multiple var declarations" = + apply_parser parse_decl {|int x = y = z = 1|} + = Ok + (SDecl + ( Var (TypeVar (TypeBase TypeInt), Id "x") + , Some + (EBinOp + ( OpAssign + , EId (Id "y") + , EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) +;; + +let%test "Parse return 1" = + apply_parser parse_return {|return 5|} = Ok (SReturn (Some (EValue (ValInt 5)))) +;; + +let%test "Parse return 2" = apply_parser parse_return {|return|} = Ok (SReturn None) +let%test "Parse break" = apply_parser parse_break {|break|} = Ok SBreak +let%test "Parse continue" = apply_parser parse_continue {|continue|} = Ok SContinue +let%test "Parse empty block" = apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) + +let%test "Parse block 1" = + apply_parser parse_block {|{return 5;}|} + = Ok (SBlock [ SReturn (Some (EValue (ValInt 5))) ]) +;; + +let%test "Parse block 2" = + apply_parser parse_block {|{int x = 6; x = 6 + 1; return x;}|} + = Ok + (SBlock + [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 6))) + ; SExpr + (EBinOp + ( OpAssign + , EId (Id "x") + , EBinOp (OpAdd, EValue (ValInt 6), EValue (ValInt 1)) )) + ; SReturn (Some (EId (Id "x"))) + ]) +;; + +let%test "Parse while" = + apply_parser + parse_block + {| + { + int x = 1; + while ( x < 1 ) + { + x = 2; + break; + continue; + } + }|} + = Ok + (SBlock + [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1))) + ; SWhile + ( EBinOp (OpLess, EId (Id "x"), EValue (ValInt 1)) + , SBlock + [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) + ; SBreak + ; SContinue + ] ) + ]) +;; + +let%test "Parse for" = + apply_parser + parse_block + {|{ + for (int i = 1;i < 5; i = i+1) + { + i = i + 1; + } + }|} + = Ok + (SBlock + [ SFor + ( Some + (SDecl + (Var (TypeVar (TypeBase TypeInt), Id "i"), Some (EValue (ValInt 1)))) + , Some (EBinOp (OpLess, EId (Id "i"), EValue (ValInt 5))) + , Some + (EBinOp + ( OpAssign + , EId (Id "i") + , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) + , SBlock + [ SExpr + (EBinOp + ( OpAssign + , EId (Id "i") + , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) + ] ) + ]) +;; + +let%test "Parse if" = + apply_parser + parse_block + {|{if (x == 5) + x=1; + else if (x == 2) + { + x=2; + } + }|} + = Ok + (SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 5)) + , SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 1))) + , Some + (SIf + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 2)) + , SBlock + [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) ] + , None )) ) + ]) +;; + +(* + let xx = + print_endline + @@ show_stmt + @@ Result.get_ok + @@ apply_parser + testttt + {|if (x == 5) + x=1; + else if (x == 2) + { + x=2; + }|} +;; +*) +let () = print_endline "Done!" + +let () = + print_pp_stmt + parse_block + {|{if (x == 5) + x=1; + else if (x == 2) + { + x=2; + } + }|} +;; diff --git a/ZarubinAlexey/.ocamlformat b/ZarubinAlexey/.ocamlformat index 97f97080..d07dcad7 100644 --- a/ZarubinAlexey/.ocamlformat +++ b/ZarubinAlexey/.ocamlformat @@ -1,2 +1,2 @@ profile=janestreet -version=0.26.2 +version=0.27.0 From db1888f0c217f6093531112f8a97aec0abe53906 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 24 Mar 2025 14:27:01 +0300 Subject: [PATCH 02/84] fix: quick fix Signed-off-by: Dmitri --- CSharpStrange/lib/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CSharpStrange/lib/dune b/CSharpStrange/lib/dune index 03116c1d..0a1db4d2 100644 --- a/CSharpStrange/lib/dune +++ b/CSharpStrange/lib/dune @@ -1,7 +1,7 @@ (library (name c_sharp_strange_lib) (public_name CSharpStrange.Lib) - (modules Ast Parser Prettyprinter Mlparser) + (modules Ast Parser) (libraries angstrom base) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_expect ppx_inline_test)) From d9866cbad0937b4e406c49bb028689ef9aad3a2f Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 24 Mar 2025 14:47:11 +0300 Subject: [PATCH 03/84] fix: class test fix Signed-off-by: Dmitri --- CSharpStrange/lib/ast.ml | 5 +++-- CSharpStrange/lib/parser.ml | 33 +++++++++++++++++------------ CSharpStrange/tests/ast_fact.t | 8 +++---- CSharpStrange/tests/parser_tests.ml | 12 ----------- 4 files changed, 26 insertions(+), 32 deletions(-) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 4320dd4a..c9e76384 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -35,6 +35,7 @@ type _type = (** Variable *) type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] +(* TODO: remove if needed - not implementing custom classes *) (** Modifiers *) type modifier = @@ -117,9 +118,9 @@ and linq_query = (** C Sharp class fields *) type field = - | VarField of modifier list * _type * ident * expr + | VarField of modifier list * var_type * ident * expr option (** Class field - always initialized *) - | Method of modifier list * _type * ident * params * stmt (** Class method *) + | Method of modifier list * var_type * ident * params * stmt (** Class method *) [@@deriving eq, show { with_path = false }] (** C Sharp class *) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index de13e3c0..1aa68a5f 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -134,10 +134,10 @@ let parse_type_word = (* TODO REMOVE AST!!!! *) take_while is_token_sym >>= function - | "int" -> return @@ Ast.TypeBase Ast.TypeInt - | "char" -> return @@ Ast.TypeBase Ast.TypeChar - | "bool" -> return @@ Ast.TypeBase Ast.TypeBool - | "string" -> return @@ Ast.TypeString + | "int" -> return @@ TypeBase TypeInt + | "char" -> return @@ TypeBase TypeChar + | "bool" -> return @@ TypeBase TypeBool + | "string" -> return @@ TypeString | _ -> fail "Wrong type word" ;; @@ -313,7 +313,7 @@ let parse_field_sign = let f_value = skip_spaces *> char '=' *> get_opt parse_ops in lift4 (fun f_modif f_type f_id f_val -> f_modif, f_type, f_id, f_val) - (option None (skip_spaces *> get_opt parse_modifiers)) + (skip_spaces *> parse_modifiers) (skip_spaces *> parse_var_type) (skip_spaces *> parse_id) (option None f_value) @@ -322,12 +322,12 @@ let parse_field_sign = let parse_method_type = (* TODO Fix!! *) - choice - [ (parse_type_word >>= fun x -> return @@ x) - ; (take_while is_token_sym - >>= fun x -> - if String.( = ) x "void" then return @@ TypeBase TypeVoid else fail "Not a type") - ] + let parse_void = + take_while is_token_sym + >>= fun x -> + if String.( = ) x "void" then return @@ TypeBase TypeVoid else fail "Not a type" + in + choice [ (parse_type_word >>= fun x -> return @@ x); parse_void ] ;; let parse_method_sign = @@ -338,16 +338,21 @@ let parse_method_sign = lift4 (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) (skip_spaces *> parse_modifiers) - (skip_spaces *> parse_method_type) + (skip_spaces *> parse_var_type) (skip_spaces *> parse_id) parse_args ;; let parse_method_member = - lift2 (fun (mds, t, id, ps) bd -> Method (mds, t, id, ps, bd)) parse_method_sign parse_block + lift2 + (fun (mds, tp, id, ps) bd -> Method (mds, tp, id, ps, bd)) + parse_method_sign + parse_block ;; -let parse_field_member = parse_field_sign >>| fun (a, b, c, d) -> VarField (a, b, c, d) +let parse_field_member = + parse_field_sign >>| fun (mds, tp, id, ex) -> VarField (mds, tp, id, ex) +;; let parse_class_members = let member = choice [ parse_method_member; parse_field_member ] in diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange/tests/ast_fact.t index 682634de..0dac16f1 100644 --- a/CSharpStrange/tests/ast_fact.t +++ b/CSharpStrange/tests/ast_fact.t @@ -1,10 +1,10 @@ $ ../bin/ast_fact.exe (Program (Class ([MPublic], (Id "Program"), - [(Method ([MPublic; MStatic], (TypeBase TypeVoid), (Id "Main"), - [], (SBlock []))); - (Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), - [((TypeBase TypeInt), "n")], + [(Method ([MPublic; MStatic], (TypeVar (TypeBase TypeVoid)), + (Id "Main"), (Params []), (SBlock []))); + (Method ([MPublic], (TypeVar (TypeBase TypeInt)), (Id "Factorial"), + (Params [(Var ((TypeVar (TypeBase TypeInt)), (Id "n")))]), (SBlock [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), (SReturn (Some (EValue (ValInt 1)))), diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index c7fb8e97..157d24e3 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -245,15 +245,3 @@ let%test "Parse if" = ;; *) let () = print_endline "Done!" - -let () = - print_pp_stmt - parse_block - {|{if (x == 5) - x=1; - else if (x == 2) - { - x=2; - } - }|} -;; From 72d5527b52e0cc09dfc871f7cf3b0ac9eea5caec Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 24 Mar 2025 16:24:37 +0300 Subject: [PATCH 04/84] fix: ast test fix Signed-off-by: Dmitri --- CSharpStrange/bin/ast_fact.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/CSharpStrange/bin/ast_fact.ml b/CSharpStrange/bin/ast_fact.ml index 6e5e3248..a3414eda 100644 --- a/CSharpStrange/bin/ast_fact.ml +++ b/CSharpStrange/bin/ast_fact.ml @@ -12,12 +12,12 @@ let fact_ast = (Class ( [ MPublic ] , Id "Program" - , [ Method ([ MPublic; MStatic ], TypeBase TypeVoid, Id "Main", [], SBlock []) + , [ Method ([ MPublic; MStatic ], TypeVar (TypeBase TypeVoid), Id "Main", Params [], SBlock []) ; Method ( [ MPublic ] - , TypeBase TypeInt + , TypeVar (TypeBase TypeInt) , Id "Factorial" - , [ TypeBase TypeInt, "n" ] + , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] , SBlock [ SIf ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) From fe5b5bc6f943bc80f1f93d4027a877eed03d52ce Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 24 Mar 2025 19:51:24 +0300 Subject: [PATCH 05/84] fix: quick parser tests fix Signed-off-by: Dmitri --- CSharpStrange/tests/parser_tests.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 157d24e3..c70a1bc9 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -1,6 +1,5 @@ open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Parser -open C_sharp_strange_lib.Prettyprinter let%test "Parse one integer" = apply_parser parse_int {|1|} = Ok (ValInt 1) let%test "Parse one char" = apply_parser parse_char {|'c'|} = Ok (ValChar 'c') From a0e8ae56bdf36727ce7f11000ce83a35b56bfc39 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Tue, 25 Mar 2025 14:57:10 +0300 Subject: [PATCH 06/84] feat: added array declaration parser Signed-off-by: Dmitri --- CSharpStrange/lib/ast.ml | 4 +-- CSharpStrange/lib/parser.ml | 63 ++++++++++++++++++++----------------- 2 files changed, 37 insertions(+), 30 deletions(-) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index c9e76384..6b7d5ce0 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -21,14 +21,14 @@ type base_type = | TypeChar (** Declaration of char *) | TypeBool (** Declaration of bool *) | TypeVoid (** Declaration of void TODO: remove by specification?? *) + | TypeString (** Declaration of string TODO*) [@@deriving eq, show { with_path = false }] (* TODO: declaration of strings?? *) (** Type delcaration *) type _type = | TypeBase of base_type (** Declaration of basic type *) - | TypeArray of base_type (** Declaration of array of basic type TODO: rank *) - | TypeString (** Declaration of string TODO*) + | TypeArray of base_type (** Declaration of array of basic type TODO: ranks & think about base_type *) [@@deriving eq, show { with_path = false }] (* TODO: records for arrays?? *) (* TODO: strings "" *) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 1aa68a5f..2977e398 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -95,28 +95,6 @@ let parse_val_string = let parse_null = string "null" *> return ValNull <|> fail "Not a null" -(* TODO: parse_array *) -let parse_array = fail "Not implemented" -let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x - -let parse_value = - choice - [ val_to_expr parse_bool - ; val_to_expr parse_char - ; val_to_expr parse_int - ; val_to_expr parse_null - ; val_to_expr parse_val_string - ] -;; - -let parse_id = - take_while is_token_sym - >>= fun str -> - match not (String.is_empty str || in_reserved str || Char.is_digit str.[0]) with - | true -> return (Id str) - | _ -> fail "Not an identifier" -;; - (* Modifiers *) let parse_modifiers = @@ -131,21 +109,49 @@ let parse_modifiers = (* Type words *) let parse_type_word = - (* TODO REMOVE AST!!!! *) take_while is_token_sym >>= function - | "int" -> return @@ TypeBase TypeInt - | "char" -> return @@ TypeBase TypeChar - | "bool" -> return @@ TypeBase TypeBool + | "int" -> return @@ TypeInt + | "char" -> return @@ TypeChar + | "bool" -> return @@ TypeBool | "string" -> return @@ TypeString | _ -> fail "Wrong type word" ;; +let parse_base_type = parse_type_word >>= fun tp -> return @@ TypeBase tp + +(* TODO: parse_divs properly *) +let parse_array_type = + let parse_divs = option None (parse_int >>= fun n -> return @@ Some n) in + lift2 (fun tp _ -> TypeArray tp) parse_type_word (brackets parse_divs) +;; + +let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x + +let parse_value = + choice + [ val_to_expr parse_bool + ; val_to_expr parse_char + ; val_to_expr parse_int + ; val_to_expr parse_null + ; val_to_expr parse_val_string + ] +;; + +let parse_id = + take_while is_token_sym + >>= fun str -> + match not (String.is_empty str || in_reserved str || Char.is_digit str.[0]) with + | true -> return (Id str) + | _ -> fail "Not an identifier" +;; + (* Expressions *) (* Variables && functions *) let parse_var_type = - parse_type_word >>= fun x -> return (TypeVar x) <|> fail "Incorrect type" + choice ?failure_msg:(Some "Incorrect type") [ parse_array_type; parse_base_type ] + >>= fun x -> return (TypeVar x) ;; let parse_var = @@ -196,6 +202,7 @@ let parse_un_op op typ = parse_op op typ >>| fun t a -> EUnOp (t, a) let ( ^!^ ) = parse_un_op "!" OpNot let parse_new = parse_un_op "new" OpNew +(* TODO: parse arrays *) let parse_ops = fix (fun expr -> let lv1 = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in @@ -327,7 +334,7 @@ let parse_method_type = >>= fun x -> if String.( = ) x "void" then return @@ TypeBase TypeVoid else fail "Not a type" in - choice [ (parse_type_word >>= fun x -> return @@ x); parse_void ] + choice [ parse_array_type; parse_base_type; parse_void ] ;; let parse_method_sign = From 572711e86c0c983848e82e3841b1d395016e607d Mon Sep 17 00:00:00 2001 From: Dmitri Date: Tue, 25 Mar 2025 14:57:39 +0300 Subject: [PATCH 07/84] test: added array parsing test Signed-off-by: Dmitri --- CSharpStrange/tests/parser_tests.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index c70a1bc9..5d210f58 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -119,6 +119,11 @@ let%test "Parse multiple var declarations" = , EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) ;; +let%test "Parse array declaration" = + apply_parser parse_decl {|int[] x|} + = Ok (SDecl (Var (TypeVar (TypeArray TypeInt), Id "x"), None)) +;; + let%test "Parse return 1" = apply_parser parse_return {|return 5|} = Ok (SReturn (Some (EValue (ValInt 5)))) ;; From 19527a8b17289cd2046e0f53f79efb025da79725 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Fri, 11 Apr 2025 17:32:57 +0300 Subject: [PATCH 08/84] fix: parser fixes; now factorial parsing should work Signed-off-by: Dmitri --- CSharpStrange/bin/ast_fact.ml | 9 +- CSharpStrange/lib/ast.ml | 17 +-- CSharpStrange/lib/parser.ml | 117 ++++++++++------ CSharpStrange/tests/ast_fact.t | 6 +- CSharpStrange/tests/parser_tests.ml | 210 ++++++++++++++++++++++++++-- 5 files changed, 284 insertions(+), 75 deletions(-) diff --git a/CSharpStrange/bin/ast_fact.ml b/CSharpStrange/bin/ast_fact.ml index a3414eda..8b5a55a2 100644 --- a/CSharpStrange/bin/ast_fact.ml +++ b/CSharpStrange/bin/ast_fact.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Dmitrii Kuznetsov *) +(** Copyright 2025, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -12,10 +12,10 @@ let fact_ast = (Class ( [ MPublic ] , Id "Program" - , [ Method ([ MPublic; MStatic ], TypeVar (TypeBase TypeVoid), Id "Main", Params [], SBlock []) + , [ Method ([ MPublic; MStatic ], TypeVoid, Id "Main", Params [], SBlock []) ; Method ( [ MPublic ] - , TypeVar (TypeBase TypeInt) + , TypeBase TypeInt , Id "Factorial" , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] , SBlock @@ -30,8 +30,7 @@ let fact_ast = , EId (Id "n") , EFuncCall ( EId (Id "Factorial") - , [ EBinOp - (OpSub, EId (Id "n"), EValue (ValInt 1)) + , [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) ] ) )))) ) ] ) ] )) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 6b7d5ce0..c330c6df 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -20,7 +20,6 @@ type base_type = | TypeInt (** Declaration of int *) | TypeChar (** Declaration of char *) | TypeBool (** Declaration of bool *) - | TypeVoid (** Declaration of void TODO: remove by specification?? *) | TypeString (** Declaration of string TODO*) [@@deriving eq, show { with_path = false }] (* TODO: declaration of strings?? *) @@ -28,7 +27,9 @@ type base_type = (** Type delcaration *) type _type = | TypeBase of base_type (** Declaration of basic type *) - | TypeArray of base_type (** Declaration of array of basic type TODO: ranks & think about base_type *) + | TypeArray of base_type + | TypeVoid (** Declaration of void TODO: remove by specification?? *) + (** Declaration of array of basic type TODO: ranks & think about base_type *) [@@deriving eq, show { with_path = false }] (* TODO: records for arrays?? *) (* TODO: strings "" *) @@ -46,7 +47,7 @@ type modifier = [@@deriving eq, show { with_path = false }] type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] -and params = Params of var_decl list [@@deriving eq, show { with_path = false }] +type params = Params of var_decl list [@@deriving eq, show { with_path = false }] (** Binary operations *) type bin_op = @@ -74,6 +75,10 @@ type un_op = | OpNew (** [new] a *) [@@deriving eq, show { with_path = false }] +(** From clauses *) +type from_clause = FromClause of string * ident +[@@deriving eq, show { with_path = false }] + (** Language expressions *) type expr = | EValue of val_type (** Some value *) @@ -104,10 +109,6 @@ and stmt = | SDecl of var_decl * expr option (** Var declaration *) [@@deriving eq, show { with_path = false }] -(** From clauses *) -and from_clause = FromClause of string * ident -[@@deriving eq, show { with_path = false }] - (** Select clause *) and select_clause = SelectClause of expr [@@deriving eq, show { with_path = false }] @@ -120,7 +121,7 @@ and linq_query = type field = | VarField of modifier list * var_type * ident * expr option (** Class field - always initialized *) - | Method of modifier list * var_type * ident * params * stmt (** Class method *) + | Method of modifier list * _type * ident * params * stmt (** Class method *) [@@deriving eq, show { with_path = false }] (** C Sharp class *) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 2977e398..50eabf49 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -1,18 +1,21 @@ +(** Copyright 2024, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open Ast open Angstrom open Base (* Chain functions *) -let chainl0 expr op = op >>= (fun op1 -> expr >>| fun exp -> op1 exp) <|> expr +let chainl0 expr op = op >>= (fun op1 -> expr >>| op1) <|> expr let chainl1 expr op = let rec pars e1 = lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 in - expr >>= fun init -> pars init + expr >>= pars ;; let chainr1 expr op = - fix (fun x -> - lift2 (fun op1 e2 -> op1 e2) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) + fix (fun x -> lift2 (fun op1 -> op1) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) ;; (* Special functions *) @@ -57,9 +60,25 @@ let is_token_sym = function ;; let skip_spaces = skip_while is_space -let parens p = skip_spaces *> char '(' *> p <* skip_spaces <* char ')' -let braces p = skip_spaces *> char '{' *> p <* skip_spaces <* char '}' -let brackets p = skip_spaces *> char '[' *> p <* skip_spaces <* char ']' + +let parens p = + skip_spaces *> (char '(' <|> fail "<(> error)") *> p + <* skip_spaces + <* (char ')' <|> fail "<)> error)") +;; + +let braces p = + skip_spaces *> (char '{' <|> fail "<{> error)") *> p + <* skip_spaces + <* (char '}' <|> fail "<}> error)") +;; + +let brackets p = + skip_spaces *> (char '[' <|> fail "<[> error)") *> p + <* skip_spaces + <* (char ']' <|> fail "<]> error)") +;; + let skip_semicolons = fix (fun f -> skip_spaces *> char ';' *> f <|> return "") let skip_semicolons1 = skip_spaces *> char ';' *> skip_semicolons @@ -67,7 +86,7 @@ let skip_semicolons1 = skip_spaces *> char ';' *> skip_semicolons let parse_int = take_while1 Char.is_digit - >>= fun num -> return @@ ValInt (int_of_string num) <|> fail "Not an int" + >>= fun num -> return @@ ValInt (Int.of_string num) <|> fail "Not an int" ;; let parse_char = @@ -105,16 +124,17 @@ let parse_modifiers = ; string "const" *> skip_spaces *> return MConst ; string "async" *> skip_spaces *> return MAsync ]) + <|> fail "Modifier error" ;; (* Type words *) let parse_type_word = take_while is_token_sym >>= function - | "int" -> return @@ TypeInt - | "char" -> return @@ TypeChar - | "bool" -> return @@ TypeBool - | "string" -> return @@ TypeString + | "int" -> return TypeInt + | "char" -> return TypeChar + | "bool" -> return TypeBool + | "string" -> return TypeString | _ -> fail "Wrong type word" ;; @@ -136,6 +156,7 @@ let parse_value = ; val_to_expr parse_null ; val_to_expr parse_val_string ] + <|> fail "Value error" ;; let parse_id = @@ -161,13 +182,9 @@ let parse_var = skip_spaces *> parse_var_type >>= parse_decl_id ;; -let parse_id_expr = skip_spaces *> parse_id >>= fun x -> return @@ EId x +let parse_id_expr = skip_spaces *> (parse_id >>| fun x -> EId x) <* skip_spaces let parse_call_id = parse_id_expr (* TODO Program.x *) - -let parse_args_list arg = - let args = arg <* skip_spaces *> char ',' <|> arg in - parens @@ many args -;; +let parse_args_list arg = parens @@ sep_by (skip_spaces *> char ',') arg let parse_call_args id arg = parse_args_list arg >>= fun args -> return @@ EFuncCall (id, args) @@ -214,9 +231,12 @@ let parse_ops = let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in chainr1 lv8 (choice [ ( ^=^ ) ])) + <|> fail "Expr error" ;; -let parse_assign = lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops +let parse_assign = + lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops <|> fail "Assign error" +;; (* Statements + LINQ *) @@ -248,6 +268,7 @@ let parse_if_else f_if_body = parse_if_cond parse_body parse_else_body) + <|> fail "If error" ;; (* TODO: Check block contains *) @@ -270,14 +291,14 @@ let parse_for body = p_for_expr) p_body in - string "for" *> p_for + string "for" *> p_for <|> fail "For error" ;; let parse_while body = let p_body = body <|> skip_semicolons1 *> parse_stmt_ops in let p_cond = parens parse_ops in let p_while = string "while" *> skip_spaces *> p_cond in - lift2 (fun cond body -> SWhile (cond, body)) p_while p_body + lift2 (fun cond body -> SWhile (cond, body)) p_while p_body <|> fail "While error" ;; let parse_return = @@ -285,10 +306,14 @@ let parse_return = (fun _ expr -> SReturn expr) (string "return") (parse_ops >>= (fun ret -> return (Some ret)) <|> return None) + <|> fail "Return error" ;; -let parse_break = skip_spaces *> string "break" *> return SBreak -let parse_continue = skip_spaces *> string "continue" *> return SContinue +let parse_break = skip_spaces *> string "break" *> return SBreak <|> fail "Break error" + +let parse_continue = + skip_spaces *> string "continue" *> return SContinue <|> fail "Continue error" +;; (* {{}} TODO ??*) @@ -316,6 +341,7 @@ let parse_block = (* Program class functions *) (* TODO - tests!! *) +(* Rewrite with lift3 lift2 *) let parse_field_sign = let f_value = skip_spaces *> char '=' *> get_opt parse_ops in lift4 @@ -328,26 +354,23 @@ let parse_field_sign = ;; let parse_method_type = - (* TODO Fix!! *) - let parse_void = - take_while is_token_sym - >>= fun x -> - if String.( = ) x "void" then return @@ TypeBase TypeVoid else fail "Not a type" - in - choice [ parse_array_type; parse_base_type; parse_void ] + let parse_void = string "void" *> (return TypeVoid) in + choice + ?failure_msg:(Some "Not a method type") + [ parse_array_type; parse_base_type; parse_void ] ;; let parse_method_sign = let parse_args = - parens @@ many @@ (skip_spaces *> parse_var <* skip_spaces <* char ',') + parens @@ sep_by (skip_spaces *> char ',' <* skip_spaces) parse_var >>= fun exp -> return (Params exp) in lift4 (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) (skip_spaces *> parse_modifiers) - (skip_spaces *> parse_var_type) + (skip_spaces *> parse_method_type) (skip_spaces *> parse_id) - parse_args + (skip_spaces *> parse_args) ;; let parse_method_member = @@ -358,32 +381,38 @@ let parse_method_member = ;; let parse_field_member = - parse_field_sign >>| fun (mds, tp, id, ex) -> VarField (mds, tp, id, ex) + parse_field_sign + >>| function + | mds, tp, id, Some ex -> VarField (mds, tp, id, Some (EBinOp (OpAssign, EId id, ex))) + | mds, tp, id, None -> VarField (mds, tp, id, None) ;; let parse_class_members = - let member = choice [ parse_method_member; parse_field_member ] in - braces @@ many member + let member = + choice ?failure_msg:(Some "Method error") [ parse_method_member; parse_field_member ] + in + braces @@ sep_by skip_spaces member ;; -let parse_one_class1 = - let class_id = skip_spaces *> string "class" *> skip_spaces *> parse_id in +let parse_class = + let class_id = + skip_spaces *> string "class" *> skip_spaces *> parse_id <|> fail "Class sign error" + in lift3 - (fun cl_modif cl_id cl_membs -> Class (cl_modif, cl_id, cl_membs)) + (fun cl_mdf cl_id cl_mbs -> Class (cl_mdf, cl_id, cl_mbs)) (skip_spaces *> parse_modifiers) class_id parse_class_members ;; -let parse_one_class = return (Class ([], Id "Not implemented", [])) -let parse_prog : program t = parse_one_class <* skip_spaces >>| fun prog -> Program prog +let parse_prog : program t = parse_class <* skip_spaces >>| fun prog -> Program prog (* Main functions *) +let apply_parser parser = parse_string ~consume:Consume.All parser + let parse_option p str = - match parse_string p ~consume:Angstrom.Consume.All str with + match apply_parser p str with | Ok x -> Some x | Error _ -> None ;; - -let apply_parser parser = parse_string ~consume:Consume.All parser diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange/tests/ast_fact.t index 0dac16f1..cdb90c1f 100644 --- a/CSharpStrange/tests/ast_fact.t +++ b/CSharpStrange/tests/ast_fact.t @@ -1,9 +1,9 @@ $ ../bin/ast_fact.exe (Program (Class ([MPublic], (Id "Program"), - [(Method ([MPublic; MStatic], (TypeVar (TypeBase TypeVoid)), - (Id "Main"), (Params []), (SBlock []))); - (Method ([MPublic], (TypeVar (TypeBase TypeInt)), (Id "Factorial"), + [(Method ([MPublic; MStatic], TypeVoid, (Id "Main"), (Params []), + (SBlock []))); + (Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), (Params [(Var ((TypeVar (TypeBase TypeInt)), (Id "n")))]), (SBlock [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 5d210f58..7e6efd57 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -1,3 +1,7 @@ +(** Copyright 2024, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Parser @@ -131,7 +135,8 @@ let%test "Parse return 1" = let%test "Parse return 2" = apply_parser parse_return {|return|} = Ok (SReturn None) let%test "Parse break" = apply_parser parse_break {|break|} = Ok SBreak let%test "Parse continue" = apply_parser parse_continue {|continue|} = Ok SContinue -let%test "Parse empty block" = apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) +let%test "Parse empty block 1" = apply_parser parse_block {|{}|} = Ok (SBlock []) +let%test "Parse empty block 2" = apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) let%test "Parse block 1" = apply_parser parse_block {|{return 5;}|} @@ -233,19 +238,194 @@ let%test "Parse if" = ]) ;; -(* - let xx = - print_endline - @@ show_stmt - @@ Result.get_ok - @@ apply_parser - testttt - {|if (x == 5) - x=1; - else if (x == 2) - { - x=2; +let%test "Parse field 1" = + apply_parser parse_field_member {|public int X;|} + = Ok (VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None)) +;; + +let%test "Parse field 2" = + apply_parser parse_field_member {|public int X = 1;|} + = Ok + (VarField + ( [ MPublic ] + , TypeVar (TypeBase TypeInt) + , Id "X" + , Some (EBinOp (OpAssign, EId (Id "X"), EValue (ValInt 1))) )) +;; + +let%test "Parse method 1" = + apply_parser parse_method_member {|public int Func() {}|} + = Ok (Method ([ MPublic ], TypeBase TypeInt, Id "Func", Params [], SBlock [])) +;; + +let%test "Parse method 2" = + apply_parser + parse_method_member + {|public int Func() + { + return 2; + }|} + = Ok + (Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "Func" + , Params [] + , SBlock [ SReturn (Some (EValue (ValInt 2))) ] )) +;; + +let%test "Parse method 3" = + apply_parser + parse_method_member + {|public int Factorial(int n) + { + if (n == 0) + { + return 1; + } + else + { + return n * Factorial(n - 1); + } + }|} + = Ok + (Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "Factorial" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] + , SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) + , SBlock [ SReturn (Some (EValue (ValInt 1))) ] + , Some + (SBlock + [ SReturn + (Some + (EBinOp + ( OpMul + , EId (Id "n") + , EFuncCall + ( EId (Id "Factorial") + , [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) + ] ) ))) + ]) ) + ] )) +;; + +let%test "Parse class 1" = + apply_parser + parse_class + {| + public class Sample {}|} + = Ok (Class ([ MPublic ], Id "Sample", [])) +;; + +let%test "Parse class 2" = + apply_parser + parse_class + {| + public class Sample { + public int X; + public int Y = 1; }|} + = Ok + (Class + ( [ MPublic ] + , Id "Sample" + , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) + ; VarField + ( [ MPublic ] + , TypeVar (TypeBase TypeInt) + , Id "Y" + , Some (EBinOp (OpAssign, EId (Id "Y"), EValue (ValInt 1))) ) + ] )) +;; + +let%test "Parse class 3" = + apply_parser + parse_class + {| + public class Sample { + + public int X; + + public int add(int x) { + X = X + x; + } + }|} + = Ok + (Class + ( [ MPublic ] + , Id "Sample" + , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) + ; Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "add" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "x") ] + , SBlock + [ SExpr + (EBinOp + ( OpAssign + , EId (Id "X") + , EBinOp (OpAdd, EId (Id "X"), EId (Id "x")) )) + ] ) + ] )) +;; + +let%test "Parse factorial" = + apply_parser + parse_prog + {| + public class Program + { + public static void Main() {} + + public int Factorial(int n) + { + if (n == 0) + { + return 1; + } + else + { + return n * Factorial(n - 1); + } + } + } + + |} + = Ok + (Program + (Class + ( [ MPublic ] + , Id "Program" + , [ Method ([ MPublic; MStatic ], TypeVoid, Id "Main", Params [], SBlock []) + ; Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "Factorial" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] + , SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) + , SBlock [ SReturn (Some (EValue (ValInt 1))) ] + , Some + (SBlock + [ SReturn + (Some + (EBinOp + ( OpMul + , EId (Id "n") + , EFuncCall + ( EId (Id "Factorial") + , [ EBinOp + ( OpSub + , EId (Id "n") + , EValue (ValInt 1) ) + ] ) ))) + ]) ) + ] ) + ] ))) ;; -*) -let () = print_endline "Done!" From cd7a8d5ab56e0040023b3225936e192fd17a9928 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Sat, 12 Apr 2025 21:26:52 +0300 Subject: [PATCH 09/84] fix: test fix Signed-off-by: Dmitri --- CSharpStrange/bin/ast_fact.ml | 3 --- CSharpStrange/bin/factorial.cs | 19 +++++++++++++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) create mode 100644 CSharpStrange/bin/factorial.cs diff --git a/CSharpStrange/bin/ast_fact.ml b/CSharpStrange/bin/ast_fact.ml index 8b5a55a2..fe13690f 100644 --- a/CSharpStrange/bin/ast_fact.ml +++ b/CSharpStrange/bin/ast_fact.ml @@ -3,9 +3,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Ast -open C_sharp_strange_lib.Parser -open Angstrom -open Printf let fact_ast = Program diff --git a/CSharpStrange/bin/factorial.cs b/CSharpStrange/bin/factorial.cs new file mode 100644 index 00000000..f85758ec --- /dev/null +++ b/CSharpStrange/bin/factorial.cs @@ -0,0 +1,19 @@ +public class Program +{ + public int Factorial(int n) + { + if (n == 0) + { + return 1; + } + else + { + return n * Factorial(n - 1); + } + } + + public static void Main() + { + + } +} \ No newline at end of file From 287f5a0df60fa058167d2b2e85e52729b8997850 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Sat, 12 Apr 2025 22:27:04 +0300 Subject: [PATCH 10/84] feat: added pretty printer Signed-off-by: Dmitri --- CSharpStrange/lib/ast.ml | 4 +- CSharpStrange/lib/dune | 2 +- CSharpStrange/lib/parser.ml | 4 +- CSharpStrange/lib/parser.mli | 36 ++++++ CSharpStrange/lib/prettyprinter.ml | 174 +++++++++++++++++++++++++++ CSharpStrange/lib/prettyprinter.mli | 7 ++ CSharpStrange/tests/dune | 6 +- CSharpStrange/tests/parser_tests.ml | 2 +- CSharpStrange/tests/parser_tests.mli | 3 + CSharpStrange/tests/pp_tests.ml | 119 ++++++++++++++++++ CSharpStrange/tests/pp_tests.mli | 3 + 11 files changed, 350 insertions(+), 10 deletions(-) create mode 100644 CSharpStrange/lib/parser.mli create mode 100644 CSharpStrange/lib/prettyprinter.ml create mode 100644 CSharpStrange/lib/prettyprinter.mli create mode 100644 CSharpStrange/tests/parser_tests.mli create mode 100644 CSharpStrange/tests/pp_tests.ml create mode 100644 CSharpStrange/tests/pp_tests.mli diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index c330c6df..0320b99f 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Dmitrii Kuznetsov *) +(** Copyright 2025, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -29,7 +29,7 @@ type _type = | TypeBase of base_type (** Declaration of basic type *) | TypeArray of base_type | TypeVoid (** Declaration of void TODO: remove by specification?? *) - (** Declaration of array of basic type TODO: ranks & think about base_type *) + (* Declaration of array of basic type TODO: ranks & think about base_type *) [@@deriving eq, show { with_path = false }] (* TODO: records for arrays?? *) (* TODO: strings "" *) diff --git a/CSharpStrange/lib/dune b/CSharpStrange/lib/dune index 0a1db4d2..1fe37a66 100644 --- a/CSharpStrange/lib/dune +++ b/CSharpStrange/lib/dune @@ -1,7 +1,7 @@ (library (name c_sharp_strange_lib) (public_name CSharpStrange.Lib) - (modules Ast Parser) + (modules Ast Parser Prettyprinter) (libraries angstrom base) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_expect ppx_inline_test)) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 50eabf49..038b1441 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Dmitrii Kuznetsov *) +(** Copyright 2025, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -354,7 +354,7 @@ let parse_field_sign = ;; let parse_method_type = - let parse_void = string "void" *> (return TypeVoid) in + let parse_void = string "void" *> return TypeVoid in choice ?failure_msg:(Some "Not a method type") [ parse_array_type; parse_base_type; parse_void ] diff --git a/CSharpStrange/lib/parser.mli b/CSharpStrange/lib/parser.mli new file mode 100644 index 00000000..8107d306 --- /dev/null +++ b/CSharpStrange/lib/parser.mli @@ -0,0 +1,36 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open Angstrom +open Base + +val parens : 'a t -> 'a t +val braces : 'a t -> 'a t +val brackets : 'a t -> 'a t + +val parse_int : val_type t +val parse_char : val_type t +val parse_bool : val_type t +val parse_val_string : val_type t + +val parse_modifiers : modifier list t + +val parse_ops : expr t + +val parse_decl : stmt t +val parse_return : stmt t +val parse_break : stmt t +val parse_continue : stmt t +val parse_block : stmt t + +val parse_method_member : field t +val parse_field_member : field t + +val parse_class : c_sharp_class t + +val parse_prog : program t + +val apply_parser : 'a t -> string -> ('a, string) result +val parse_option : 'a t -> string -> 'a option diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml new file mode 100644 index 00000000..d2d4c8c9 --- /dev/null +++ b/CSharpStrange/lib/prettyprinter.ml @@ -0,0 +1,174 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Format +open Ast + +let pp_list : 'a. (formatter -> 'a -> unit) -> string -> formatter -> 'a list -> unit = + fun pp sep fmt lst -> + let rec aux fmt = function + | [] -> () + | [ x ] -> pp fmt x + | x :: xs -> fprintf fmt "%a%s%a" pp x sep aux xs + in + aux fmt lst +;; + +let pp_option : 'a. (formatter -> 'a -> unit) -> formatter -> 'a option -> unit = + fun pp fmt -> function + | None -> fprintf fmt "" + | Some x -> pp fmt x +;; + +let pp_ident fmt (Id s) = fprintf fmt "%s" s + +let pp_base_type fmt = function + | TypeInt -> fprintf fmt "int" + | TypeChar -> fprintf fmt "char" + | TypeBool -> fprintf fmt "bool" + | TypeString -> fprintf fmt "string" +;; + +let pp_type fmt = function + | TypeBase bt -> pp_base_type fmt bt + | TypeArray bt -> fprintf fmt "%a[]" pp_base_type bt + | TypeVoid -> fprintf fmt "void" +;; + +let pp_var_type fmt (TypeVar t) = pp_type fmt t + +let pp_modifier fmt = function + | MPublic -> fprintf fmt "public" + | MStatic -> fprintf fmt "static" + | MConst -> fprintf fmt "const" + | MAsync -> fprintf fmt "async" +;; + +let pp_var_decl fmt (Var (vt, id)) = fprintf fmt "%a %a" pp_var_type vt pp_ident id + +let pp_bin_op fmt = function + | OpAdd -> f -> fprintf fmt "!=" + | OpLess -> fprintf fmt "<" + | OpMore -> fprintf fmt ">" + | OpLessEqual -> fprintf fmt "<=" + | OpMoreEqual -> fprintf fmt ">=" + | OpAnd -> fprintf fmt "&&" + | OpOr -> fprintf fmt "||" + | OpAssign -> fprintf fmt "=" +;; + +let pp_un_op fmt = function + | OpInc -> fprintf fmt "++" + | OpDec -> fprintf fmt "--" + | OpNot -> fprintf fmt "!" + | OpNew -> fprintf fmt "new" +;; + +let rec pp_val_type fmt = function + | ValInt n -> fprintf fmt "%d" n + | ValChar c -> fprintf fmt "'%c'" c + | ValNull -> fprintf fmt "null" + | ValBool b -> fprintf fmt "%b" b + | ValArray vs -> fprintf fmt "[|%a|]" (pp_list pp_val_type "; ") vs + | ValString s -> fprintf fmt {|%S|} s +;; + +let rec pp_expr fmt = function + | EValue v -> pp_val_type fmt v + | EBinOp (op, e1, e2) -> fprintf fmt "(%a %a %a)" pp_expr e1 pp_bin_op op pp_expr e2 + | EUnOp (op, e) -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e + | EConst v -> fprintf fmt "const %a" pp_val_type v + | EId id -> pp_ident fmt id + | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 + | EFuncCall (e, args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args + | ELambda (e, s) -> fprintf fmt "(%a => %a)" pp_expr e pp_stmt s + | EAwait e -> fprintf fmt "await %a" pp_expr e + | ELinqQuery q -> pp_linq_query fmt q + +and pp_from_clause fmt (FromClause (s, id)) = fprintf fmt "from %a in %s" pp_ident id s +and pp_select_clause fmt (SelectClause e) = fprintf fmt "select %a" pp_expr e + +and pp_linq_query fmt (SQuery (fc, sc)) = + fprintf fmt "%a %a" pp_from_clause fc pp_select_clause sc +;; + +let rec pp_stmt fmt = function + | SFor (init, cond, incr, body) -> + fprintf + fmt + "@[for (%a; %a; %a) {@ %a@]@ }" + (pp_option pp_stmt) + init + (pp_option pp_expr) + cond + (pp_option pp_expr) + incr + pp_stmt + body + | SIf (cond, then_branch, else_branch) -> + fprintf + fmt + "@[if (%a) {@ %a@]@ }%a" + pp_expr + cond + pp_stmt + then_branch + (pp_option (fun fmt -> fprintf fmt "@ @[else {@ %a@]@ }" pp_stmt)) + else_branch + | SWhile (cond, body) -> + fprintf fmt "@[while (%a) {@ %a@]@ }" pp_expr cond pp_stmt body + | SReturn e -> fprintf fmt "return %a;" (pp_option pp_expr) e + | SBlock stmts -> pp_sblock fmt stmts + | SBreak -> fprintf fmt "break;" + | SContinue -> fprintf fmt "continue;" + | SExpr e -> fprintf fmt "%a;" pp_expr e + | SDecl (vd, e) -> fprintf fmt "%a = %a;" pp_var_decl vd (pp_option pp_expr) e + +and pp_sblock fmt = function + | [] -> fprintf fmt "" + | stmts -> fprintf fmt "@[%a@]" (pp_list pp_stmt "@ ") stmts +;; + +let pp_field fmt = function + | VarField (mods, t, id, e) -> + fprintf + fmt + "@[%a %a %a = %a;@]" + (pp_list pp_modifier " ") + mods + pp_var_type + t + pp_ident + id + (pp_option pp_expr) + e + | Method (mods, t, id, Params params, body) -> + fprintf + fmt + "@[%a %a %a(%a)@ @[{@ %a@]@ @[}@]@ " + (pp_list pp_modifier " ") + mods + pp_type + t + pp_ident + id + (pp_list pp_var_decl ", ") + params + pp_stmt + body +;; + +let pp_c_sharp_class fmt (Class (mods, id, fields)) = + fprintf + fmt + "@[%a class %a@ @[{@ %a@]@ @[}@]" + (pp_list pp_modifier " ") + mods + pp_ident + id + (pp_list pp_field " ") + fields +;; + +let pp_prog fmt (Program cls) = pp_c_sharp_class fmt cls diff --git a/CSharpStrange/lib/prettyprinter.mli b/CSharpStrange/lib/prettyprinter.mli new file mode 100644 index 00000000..949077e6 --- /dev/null +++ b/CSharpStrange/lib/prettyprinter.mli @@ -0,0 +1,7 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast + +val pp_prog : Format.formatter -> program -> unit diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index 30003bcf..06dfb81a 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -1,7 +1,7 @@ (library (name tests) (public_name CSharpStrange.Lib.Tests) - (modules Parser_tests) + (modules Parser_tests Pp_tests) (libraries angstrom c_sharp_strange_lib) (inline_tests) (instrumentation @@ -11,6 +11,4 @@ (cram (applies_to ast_fact) - (deps - ../bin/ast_fact.exe - ../bin/factorial.cs)) + (deps ../bin/ast_fact.exe ../bin/factorial.cs)) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 7e6efd57..c74ce0f4 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Dmitrii Kuznetsov *) +(** Copyright 2025, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange/tests/parser_tests.mli b/CSharpStrange/tests/parser_tests.mli new file mode 100644 index 00000000..2a5ede90 --- /dev/null +++ b/CSharpStrange/tests/parser_tests.mli @@ -0,0 +1,3 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange/tests/pp_tests.ml b/CSharpStrange/tests/pp_tests.ml new file mode 100644 index 00000000..af45e684 --- /dev/null +++ b/CSharpStrange/tests/pp_tests.ml @@ -0,0 +1,119 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open C_sharp_strange_lib.Prettyprinter +open C_sharp_strange_lib.Parser +open Format + +let fact_str = + {| +public class Program +{ + public int Factorial(int n) + { + if (n == 0) + { + return 1; + } + else + { + return n * Factorial(n - 1); + } + } + + public static void Main() + { + + } +} + +|} +;; + +let fact_prog = parse_option parse_prog fact_str + +let pretty_fact_str = function + | Some x -> asprintf "%a" pp_prog x + | None -> "" +;; + +let parse_after_pp prog = parse_option parse_prog (pretty_fact_str prog) +let%test "Factorial pp" = parse_after_pp fact_prog = fact_prog + +let cycles_str = + {| +public class Program +{ + public int Cycles(int n, bool e, string x) + { + int x = 0; + while (x < n) + { + if (x == -1) + { + break; + } + + if (x == -2) + { + continue; + } + + x = x + 1; + } + + for (int i = 1; i < n; i++) + { + break; + } + + for (;;) + { + break; + } + + for (int i = 1;; i++) + { + break; + } + } + + public static void Main() + { + Cycles(5, true, "sample"); + } +} +|} +;; + +let cycles_prog = parse_option parse_prog cycles_str +let%test "Cycles pp" = parse_after_pp cycles_prog = cycles_prog + +let binops_prog = + parse_option + parse_prog + {| + +public class Program +{ + public int Binops(int n, bool e, string x) + { + int x_ = n; + bool sample = !e || ((1 + 2 < 3 + 4) && (5 == 8)); + string e = x; + char eeAe065ef = 'a'; + e = null; + const int a = 1; + } + + + public static void Main() + { + Binops(5, true, ""); + } +} +|} +;; + +let%test "Binops pp" = parse_after_pp binops_prog = binops_prog diff --git a/CSharpStrange/tests/pp_tests.mli b/CSharpStrange/tests/pp_tests.mli new file mode 100644 index 00000000..2a5ede90 --- /dev/null +++ b/CSharpStrange/tests/pp_tests.mli @@ -0,0 +1,3 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From bf2458d981952f5a09a993a98edc37d9352c4352 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 20:26:52 +0300 Subject: [PATCH 11/84] fix: quick fixes Signed-off-by: Dmitri --- CSharpStrange/lib/parser.mli | 10 +--------- CSharpStrange/lib/prettyprinter.ml | 8 +++++++- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/CSharpStrange/lib/parser.mli b/CSharpStrange/lib/parser.mli index 8107d306..730e660b 100644 --- a/CSharpStrange/lib/parser.mli +++ b/CSharpStrange/lib/parser.mli @@ -9,28 +9,20 @@ open Base val parens : 'a t -> 'a t val braces : 'a t -> 'a t val brackets : 'a t -> 'a t - val parse_int : val_type t val parse_char : val_type t val parse_bool : val_type t val parse_val_string : val_type t - val parse_modifiers : modifier list t - val parse_ops : expr t - val parse_decl : stmt t val parse_return : stmt t val parse_break : stmt t val parse_continue : stmt t val parse_block : stmt t - val parse_method_member : field t val parse_field_member : field t - val parse_class : c_sharp_class t - val parse_prog : program t - -val apply_parser : 'a t -> string -> ('a, string) result +val apply_parser : 'a t -> string -> ('a, string) Result.t val parse_option : 'a t -> string -> 'a option diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml index d2d4c8c9..828a8385 100644 --- a/CSharpStrange/lib/prettyprinter.ml +++ b/CSharpStrange/lib/prettyprinter.ml @@ -48,7 +48,13 @@ let pp_modifier fmt = function let pp_var_decl fmt (Var (vt, id)) = fprintf fmt "%a %a" pp_var_type vt pp_ident id let pp_bin_op fmt = function - | OpAdd -> f -> fprintf fmt "!=" + | OpAdd -> fprintf fmt "+" + | OpSub -> fprintf fmt "-" + | OpMul -> fprintf fmt "*" + | OpDiv -> fprintf fmt "/" + | OpMod -> fprintf fmt "%%" + | OpEqual -> fprintf fmt "==" + | OpNonEqual -> fprintf fmt "!=" | OpLess -> fprintf fmt "<" | OpMore -> fprintf fmt ">" | OpLessEqual -> fprintf fmt "<=" From cdaea8a1e60ab06dc571cc557b16322bacf4bcd0 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 20:57:15 +0300 Subject: [PATCH 12/84] feat: removed TODOs + unfinished features Signed-off-by: Dmitri --- CSharpStrange/lib/ast.ml | 45 ++++++----------------------- CSharpStrange/lib/parser.ml | 35 ++++------------------ CSharpStrange/lib/prettyprinter.ml | 15 ---------- CSharpStrange/tests/parser_tests.ml | 7 +---- 4 files changed, 15 insertions(+), 87 deletions(-) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 0320b99f..83ec7fc1 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -8,8 +8,7 @@ type val_type = | ValChar of char (** Char value *) | ValNull (** Null *) | ValBool of bool (** Bool value *) - | ValArray of val_type list (** TODO: array value *) - | ValString of string (** TODO: string value *) + | ValString of string (** string value *) [@@deriving eq, show { with_path = false }] (** Identidicator *) @@ -20,29 +19,22 @@ type base_type = | TypeInt (** Declaration of int *) | TypeChar (** Declaration of char *) | TypeBool (** Declaration of bool *) - | TypeString (** Declaration of string TODO*) + | TypeString (** Declaration of string *) [@@deriving eq, show { with_path = false }] -(* TODO: declaration of strings?? *) (** Type delcaration *) type _type = | TypeBase of base_type (** Declaration of basic type *) - | TypeArray of base_type - | TypeVoid (** Declaration of void TODO: remove by specification?? *) - (* Declaration of array of basic type TODO: ranks & think about base_type *) + | TypeVoid (** Declaration of void *) [@@deriving eq, show { with_path = false }] -(* TODO: records for arrays?? *) -(* TODO: strings "" *) (** Variable *) type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] -(* TODO: remove if needed - not implementing custom classes *) (** Modifiers *) type modifier = | MPublic (** Public modifier, used for main() method only *) | MStatic (** Static modifier, used for main() method only *) - | MConst (** Const modifier *) (* TODO *) | MAsync (** Async modifier *) [@@deriving eq, show { with_path = false }] @@ -68,12 +60,7 @@ type bin_op = [@@deriving eq, show { with_path = false }] (** Unary operations *) -type un_op = - | OpInc (** [++] a or [++] a *) (* TODO remove?? *) - | OpDec (** [--] a or [--] a *) (* TODO remove?? *) - | OpNot (** [!] a *) - | OpNew (** [new] a *) -[@@deriving eq, show { with_path = false }] +type un_op = OpNot (** [!] a *) [@@deriving eq, show { with_path = false }] (** From clauses *) type from_clause = FromClause of string * ident @@ -84,14 +71,10 @@ type expr = | EValue of val_type (** Some value *) | EBinOp of bin_op * expr * expr (** Binary operation *) | EUnOp of un_op * expr (** Unary operation *) - | EConst of val_type (** Const expression TODO change for modifiers?? *) | EId of ident (** Identificator expression *) | EArrayAccess of expr * expr (** Array access: a = arr[i] *) - | EFuncCall of expr * expr list - (** Call of function: name(arguments) TODO: Program.x() *) - | ELambda of expr * stmt (** Lambda expressions *) - | EAwait of expr (** Await expression *) - | ELinqQuery of linq_query (** from identifier in expr select expr *) + | EFuncCall of expr * expr list (** Call of function: name(arguments) *) + | EAwait of expr (** [Await] expression *) [@@deriving eq, show { with_path = false }] (** Language statements *) @@ -101,22 +84,14 @@ and stmt = | SIf of expr * stmt * stmt option (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) - | SReturn of expr option (** Return: return (a) *) + | SReturn of expr option (** Return: [return] (a) *) | SBlock of stmt list (** Block of statements: \{ a \}; could be empty: \{\} *) - | SBreak (** Cycle break *) - | SContinue (** Cycle continue *) + | SBreak (** Cycle [break] *) + | SContinue (** Cycle [continue] *) | SExpr of expr (** Another expression *) | SDecl of var_decl * expr option (** Var declaration *) [@@deriving eq, show { with_path = false }] -(** Select clause *) -and select_clause = SelectClause of expr [@@deriving eq, show { with_path = false }] - -(** LINQ query *) -and linq_query = - | SQuery of from_clause * select_clause (** from identifier in identifier select expr *) -[@@deriving eq, show { with_path = false }] - (** C Sharp class fields *) type field = | VarField of modifier list * var_type * ident * expr option @@ -131,5 +106,3 @@ type c_sharp_class = (** Program AST *) type program = Program of c_sharp_class [@@deriving eq, show { with_path = false }] - -(* TODO: read specification!! + write factorial parser from scratch *) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 038b1441..872b06db 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -27,7 +27,6 @@ let reserved = ; "while" ; "public" ; "static" - ; "const" ; "void" ; "string" ; "char" @@ -42,8 +41,6 @@ let reserved = ; "class" ; "async" ; "await" - ; "select" - ; "from" ] ;; @@ -121,7 +118,6 @@ let parse_modifiers = (choice [ string "public" *> skip_spaces *> return MPublic ; string "static" *> skip_spaces *> return MStatic - ; string "const" *> skip_spaces *> return MConst ; string "async" *> skip_spaces *> return MAsync ]) <|> fail "Modifier error" @@ -139,13 +135,6 @@ let parse_type_word = ;; let parse_base_type = parse_type_word >>= fun tp -> return @@ TypeBase tp - -(* TODO: parse_divs properly *) -let parse_array_type = - let parse_divs = option None (parse_int >>= fun n -> return @@ Some n) in - lift2 (fun tp _ -> TypeArray tp) parse_type_word (brackets parse_divs) -;; - let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x let parse_value = @@ -171,7 +160,7 @@ let parse_id = (* Variables && functions *) let parse_var_type = - choice ?failure_msg:(Some "Incorrect type") [ parse_array_type; parse_base_type ] + choice ?failure_msg:(Some "Incorrect type") [ parse_base_type ] >>= fun x -> return (TypeVar x) ;; @@ -183,7 +172,7 @@ let parse_var = ;; let parse_id_expr = skip_spaces *> (parse_id >>| fun x -> EId x) <* skip_spaces -let parse_call_id = parse_id_expr (* TODO Program.x *) +let parse_call_id = parse_id_expr let parse_args_list arg = parens @@ sep_by (skip_spaces *> char ',') arg let parse_call_args id arg = @@ -214,16 +203,12 @@ let ( ^=^ ) = parse_bin_op "=" OpAssign (* Unary operations *) let parse_un_op op typ = parse_op op typ >>| fun t a -> EUnOp (t, a) - -(*TODO: check for increment/decrement ??*) let ( ^!^ ) = parse_un_op "!" OpNot -let parse_new = parse_un_op "new" OpNew -(* TODO: parse arrays *) let parse_ops = fix (fun expr -> let lv1 = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in - let lv2 = chainl0 lv1 (choice [ parse_new; ( ^!^ ) ]) in + let lv2 = chainl0 lv1 (choice [ ( ^!^ ) ]) in let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in @@ -238,7 +223,7 @@ let parse_assign = lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops <|> fail "Assign error" ;; -(* Statements + LINQ *) +(* Statements *) let get_opt p = p >>| fun x -> Some x @@ -249,11 +234,9 @@ let parse_decl = (option None (skip_spaces *> char '=' *> parse_ops >>| fun e -> Some e)) ;; -(* TODO: check other return "" *) let expr_to_stmt expr = expr >>| fun x -> SExpr x let parse_stmt_ops = expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] -(* TODO: Check block contains (esp. other ifs) *) let parse_if_else f_if_body = let parse_if_cond = string "if" *> skip_spaces *> parens parse_ops in let parse_else_cond ifls body = @@ -271,7 +254,6 @@ let parse_if_else f_if_body = <|> fail "If error" ;; -(* TODO: Check block contains *) let parse_for body = let expr_to_option_stmt expr = get_opt @@ expr_to_stmt expr in let p_body = body <|> (parse_stmt_ops <* skip_semicolons1) in @@ -315,8 +297,6 @@ let parse_continue = skip_spaces *> string "continue" *> return SContinue <|> fail "Continue error" ;; -(* {{}} TODO ??*) - let parse_block = fix (fun block -> let sc p = p <* skip_semicolons1 in @@ -339,9 +319,6 @@ let parse_block = ;; (* Program class functions *) -(* TODO - tests!! *) - -(* Rewrite with lift3 lift2 *) let parse_field_sign = let f_value = skip_spaces *> char '=' *> get_opt parse_ops in lift4 @@ -355,9 +332,7 @@ let parse_field_sign = let parse_method_type = let parse_void = string "void" *> return TypeVoid in - choice - ?failure_msg:(Some "Not a method type") - [ parse_array_type; parse_base_type; parse_void ] + choice ?failure_msg:(Some "Not a method type") [ parse_base_type; parse_void ] ;; let parse_method_sign = diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml index 828a8385..3fe14ce1 100644 --- a/CSharpStrange/lib/prettyprinter.ml +++ b/CSharpStrange/lib/prettyprinter.ml @@ -32,7 +32,6 @@ let pp_base_type fmt = function let pp_type fmt = function | TypeBase bt -> pp_base_type fmt bt - | TypeArray bt -> fprintf fmt "%a[]" pp_base_type bt | TypeVoid -> fprintf fmt "void" ;; @@ -41,7 +40,6 @@ let pp_var_type fmt (TypeVar t) = pp_type fmt t let pp_modifier fmt = function | MPublic -> fprintf fmt "public" | MStatic -> fprintf fmt "static" - | MConst -> fprintf fmt "const" | MAsync -> fprintf fmt "async" ;; @@ -65,10 +63,7 @@ let pp_bin_op fmt = function ;; let pp_un_op fmt = function - | OpInc -> fprintf fmt "++" - | OpDec -> fprintf fmt "--" | OpNot -> fprintf fmt "!" - | OpNew -> fprintf fmt "new" ;; let rec pp_val_type fmt = function @@ -76,7 +71,6 @@ let rec pp_val_type fmt = function | ValChar c -> fprintf fmt "'%c'" c | ValNull -> fprintf fmt "null" | ValBool b -> fprintf fmt "%b" b - | ValArray vs -> fprintf fmt "[|%a|]" (pp_list pp_val_type "; ") vs | ValString s -> fprintf fmt {|%S|} s ;; @@ -84,19 +78,10 @@ let rec pp_expr fmt = function | EValue v -> pp_val_type fmt v | EBinOp (op, e1, e2) -> fprintf fmt "(%a %a %a)" pp_expr e1 pp_bin_op op pp_expr e2 | EUnOp (op, e) -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e - | EConst v -> fprintf fmt "const %a" pp_val_type v | EId id -> pp_ident fmt id | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 | EFuncCall (e, args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args - | ELambda (e, s) -> fprintf fmt "(%a => %a)" pp_expr e pp_stmt s | EAwait e -> fprintf fmt "await %a" pp_expr e - | ELinqQuery q -> pp_linq_query fmt q - -and pp_from_clause fmt (FromClause (s, id)) = fprintf fmt "from %a in %s" pp_ident id s -and pp_select_clause fmt (SelectClause e) = fprintf fmt "select %a" pp_expr e - -and pp_linq_query fmt (SQuery (fc, sc)) = - fprintf fmt "%a %a" pp_from_clause fc pp_select_clause sc ;; let rec pp_stmt fmt = function diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index c74ce0f4..5daf3787 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -21,7 +21,7 @@ let%test "Parse one modifier 1" = apply_parser parse_modifiers {|static|} = Ok [ let%test "Parse one modifier 2" = apply_parser parse_modifiers {|public|} = Ok [ MPublic ] let%test "Parse two modifiers" = - apply_parser parse_modifiers {|const async|} = Ok [ MConst; MAsync ] + apply_parser parse_modifiers {|public async|} = Ok [ MPublic; MAsync ] ;; let%test "Parse add 1" = @@ -123,11 +123,6 @@ let%test "Parse multiple var declarations" = , EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) ;; -let%test "Parse array declaration" = - apply_parser parse_decl {|int[] x|} - = Ok (SDecl (Var (TypeVar (TypeArray TypeInt), Id "x"), None)) -;; - let%test "Parse return 1" = apply_parser parse_return {|return 5|} = Ok (SReturn (Some (EValue (ValInt 5)))) ;; From 9b2a38a006fe0a7c7a9180c4a5275032053296ca Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 21:01:28 +0300 Subject: [PATCH 13/84] fix: linter fix Signed-off-by: Dmitri --- CSharpStrange/lib/ast.ml | 2 +- CSharpStrange/lib/prettyprinter.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 83ec7fc1..253de53b 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -78,7 +78,7 @@ type expr = [@@deriving eq, show { with_path = false }] (** Language statements *) -and stmt = +type stmt = | SFor of stmt option * expr option * expr option * stmt (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) | SIf of expr * stmt * stmt option diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml index 3fe14ce1..a8e971cf 100644 --- a/CSharpStrange/lib/prettyprinter.ml +++ b/CSharpStrange/lib/prettyprinter.ml @@ -66,7 +66,7 @@ let pp_un_op fmt = function | OpNot -> fprintf fmt "!" ;; -let rec pp_val_type fmt = function +let pp_val_type fmt = function | ValInt n -> fprintf fmt "%d" n | ValChar c -> fprintf fmt "'%c'" c | ValNull -> fprintf fmt "null" From a0ceb7fee764bbbb0916f5f2056e1ab2022cf2c8 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 21:27:44 +0300 Subject: [PATCH 14/84] feat: added REPL with test Signed-off-by: Dmitri --- CSharpStrange/bin/REPL.ml | 31 ++++++++++++++++++++++++++ CSharpStrange/bin/ast_fact.ml | 36 ------------------------------ CSharpStrange/bin/dune | 7 ++++++ CSharpStrange/tests/ast_fact.t | 40 ++++++++++++++++++---------------- CSharpStrange/tests/dune | 2 +- 5 files changed, 60 insertions(+), 56 deletions(-) create mode 100644 CSharpStrange/bin/REPL.ml delete mode 100644 CSharpStrange/bin/ast_fact.ml create mode 100644 CSharpStrange/bin/dune diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml new file mode 100644 index 00000000..18e2e8cf --- /dev/null +++ b/CSharpStrange/bin/REPL.ml @@ -0,0 +1,31 @@ +open C_sharp_strange_lib.Ast +open C_sharp_strange_lib.Parser +open Printf +open Stdio + +type opts = + { mutable dump_parse_tree : bool + ; mutable file_path : string option + } + +let () = + let opts = { dump_parse_tree = false; file_path = None } in + let _ = + Arg.parse + [ "-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n" + ; "-filepath", Arg.String (fun file_path -> opts.file_path <- Some file_path), "\n" + ] + (fun _ -> + Stdlib.Format.eprintf "Something got wrong\n"; + Stdlib.exit 1) + "\n" + in + let path = + match opts.file_path with + | None -> String.trim @@ In_channel.input_all stdin + | Some path -> String.trim @@ In_channel.read_all path + in + match apply_parser parse_prog path with + | Ok ast -> if opts.dump_parse_tree then print_endline (show_program ast) + | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) +;; diff --git a/CSharpStrange/bin/ast_fact.ml b/CSharpStrange/bin/ast_fact.ml deleted file mode 100644 index fe13690f..00000000 --- a/CSharpStrange/bin/ast_fact.ml +++ /dev/null @@ -1,36 +0,0 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open C_sharp_strange_lib.Ast - -let fact_ast = - Program - (Class - ( [ MPublic ] - , Id "Program" - , [ Method ([ MPublic; MStatic ], TypeVoid, Id "Main", Params [], SBlock []) - ; Method - ( [ MPublic ] - , TypeBase TypeInt - , Id "Factorial" - , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] - , SBlock - [ SIf - ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) - , SReturn (Some (EValue (ValInt 1))) - , Some - (SReturn - (Some - (EBinOp - ( OpMul - , EId (Id "n") - , EFuncCall - ( EId (Id "Factorial") - , [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) - ] ) )))) ) - ] ) - ] )) -;; - -let () = print_endline (show_program fact_ast) (* AST print test *) diff --git a/CSharpStrange/bin/dune b/CSharpStrange/bin/dune new file mode 100644 index 00000000..df2113e7 --- /dev/null +++ b/CSharpStrange/bin/dune @@ -0,0 +1,7 @@ +(executable + (name REPL) + (public_name REPL) + (modules REPL) + (libraries c_sharp_strange_lib stdio) + (instrumentation + (backend bisect_ppx))) \ No newline at end of file diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange/tests/ast_fact.t index cdb90c1f..f62ed32b 100644 --- a/CSharpStrange/tests/ast_fact.t +++ b/CSharpStrange/tests/ast_fact.t @@ -1,23 +1,25 @@ - $ ../bin/ast_fact.exe + $ ../bin/REPL.exe -parseast -filepath="../bin/factorial.cs" (Program (Class ([MPublic], (Id "Program"), - [(Method ([MPublic; MStatic], TypeVoid, (Id "Main"), (Params []), - (SBlock []))); - (Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), - (Params [(Var ((TypeVar (TypeBase TypeInt)), (Id "n")))]), - (SBlock - [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), - (SReturn (Some (EValue (ValInt 1)))), - (Some (SReturn - (Some (EBinOp (OpMul, (EId (Id "n")), - (EFuncCall ((EId (Id "Factorial")), - [(EBinOp (OpSub, (EId (Id "n")), - (EValue (ValInt 1)))) - ] - )) - ))))) - )) - ]) - )) + [(Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), + (Params [(Var ((TypeVar (TypeBase TypeInt)), (Id "n")))]), + (SBlock + [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), + (SBlock [(SReturn (Some (EValue (ValInt 1))))]), + (Some (SBlock + [(SReturn + (Some (EBinOp (OpMul, (EId (Id "n")), + (EFuncCall ((EId (Id "Factorial")), + [(EBinOp (OpSub, (EId (Id "n")), + (EValue (ValInt 1)))) + ] + )) + )))) + ])) + )) + ]) + )); + (Method ([MPublic; MStatic], TypeVoid, (Id "Main"), (Params []), + (SBlock []))) ] ))) diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index 06dfb81a..161cc0dc 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -11,4 +11,4 @@ (cram (applies_to ast_fact) - (deps ../bin/ast_fact.exe ../bin/factorial.cs)) + (deps ../bin/ast_fact.exe ../bin/REPL.exe ../bin/factorial.cs)) From 9e6eb8d5a1a3a074342e1b9db9b5b04992ab5acb Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 21:29:30 +0300 Subject: [PATCH 15/84] fix: dune fix Signed-off-by: Dmitri --- CSharpStrange/tests/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index 161cc0dc..f112a01f 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -11,4 +11,4 @@ (cram (applies_to ast_fact) - (deps ../bin/ast_fact.exe ../bin/REPL.exe ../bin/factorial.cs)) + (deps ../bin/REPL.exe ../bin/factorial.cs)) From 9be84029c1b43bd95c64334898a1f11dca4d5a6e Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 21:32:53 +0300 Subject: [PATCH 16/84] fix: formatting Signed-off-by: Dmitri --- CSharpStrange/bin/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CSharpStrange/bin/dune b/CSharpStrange/bin/dune index df2113e7..f1f0d767 100644 --- a/CSharpStrange/bin/dune +++ b/CSharpStrange/bin/dune @@ -4,4 +4,4 @@ (modules REPL) (libraries c_sharp_strange_lib stdio) (instrumentation - (backend bisect_ppx))) \ No newline at end of file + (backend bisect_ppx))) From b0b3c9efd596afc1a64ae11ccf19b9b6eb3e5fe8 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 22:17:12 +0300 Subject: [PATCH 17/84] fix: restored old version of ocamlformat Signed-off-by: Dmitri --- ZarubinAlexey/.ocamlformat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ZarubinAlexey/.ocamlformat b/ZarubinAlexey/.ocamlformat index d07dcad7..97f97080 100644 --- a/ZarubinAlexey/.ocamlformat +++ b/ZarubinAlexey/.ocamlformat @@ -1,2 +1,2 @@ profile=janestreet -version=0.27.0 +version=0.26.2 From 4deaaa49e56fb20951d74b173223ea63ccb922b3 Mon Sep 17 00:00:00 2001 From: Dmitri Date: Mon, 14 Apr 2025 22:20:10 +0300 Subject: [PATCH 18/84] fix: formatting Signed-off-by: Dmitri --- CSharpStrange/bin/REPL.ml | 4 ++-- CSharpStrange/lib/ast.ml | 2 +- CSharpStrange/lib/parser.ml | 2 +- CSharpStrange/tests/parser_tests.ml | 8 ++------ 4 files changed, 6 insertions(+), 10 deletions(-) diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml index 18e2e8cf..26d45ea3 100644 --- a/CSharpStrange/bin/REPL.ml +++ b/CSharpStrange/bin/REPL.ml @@ -16,8 +16,8 @@ let () = ; "-filepath", Arg.String (fun file_path -> opts.file_path <- Some file_path), "\n" ] (fun _ -> - Stdlib.Format.eprintf "Something got wrong\n"; - Stdlib.exit 1) + Stdlib.Format.eprintf "Something got wrong\n"; + Stdlib.exit 1) "\n" in let path = diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 253de53b..7f03ac5b 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -33,7 +33,7 @@ type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] (** Modifiers *) type modifier = - | MPublic (** Public modifier, used for main() method only *) + | MPublic (** Public modifier, used for main() method only *) | MStatic (** Static modifier, used for main() method only *) | MAsync (** Async modifier *) [@@deriving eq, show { with_path = false }] diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 872b06db..9b001915 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -264,7 +264,7 @@ let parse_for body = let p_for = lift2 (fun (f_init_p, f_cond_p, f_iter_p) f_body -> - SFor (f_init_p, f_cond_p, f_iter_p, f_body)) + SFor (f_init_p, f_cond_p, f_iter_p, f_body)) (parens @@ lift3 (fun init cond incr -> init, cond, incr) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 5daf3787..bcc62dba 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -254,9 +254,7 @@ let%test "Parse method 1" = ;; let%test "Parse method 2" = - apply_parser - parse_method_member - {|public int Func() + apply_parser parse_method_member {|public int Func() { return 2; }|} @@ -309,9 +307,7 @@ let%test "Parse method 3" = ;; let%test "Parse class 1" = - apply_parser - parse_class - {| + apply_parser parse_class {| public class Sample {}|} = Ok (Class ([ MPublic ], Id "Sample", [])) ;; From 6045b80180110b754b159b055cbef3aeaf2d63fc Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 13 Oct 2025 19:18:11 +0300 Subject: [PATCH 19/84] feat: added first version of typecheck Signed-off-by: f1i3g3 --- CSharpStrange/lib/ast.ml | 3 +- CSharpStrange/lib/common.ml | 32 ++++ CSharpStrange/lib/dune | 2 +- CSharpStrange/lib/monads.ml | 165 ++++++++++++++++++ CSharpStrange/lib/typecheck.ml | 303 +++++++++++++++++++++++++++++++++ 5 files changed, 503 insertions(+), 2 deletions(-) create mode 100644 CSharpStrange/lib/common.ml create mode 100644 CSharpStrange/lib/monads.ml create mode 100644 CSharpStrange/lib/typecheck.ml diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 7f03ac5b..b2c05850 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -40,6 +40,7 @@ type modifier = type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] type params = Params of var_decl list [@@deriving eq, show { with_path = false }] +(* TODO: ?? *) (** Binary operations *) type bin_op = @@ -73,7 +74,7 @@ type expr = | EUnOp of un_op * expr (** Unary operation *) | EId of ident (** Identificator expression *) | EArrayAccess of expr * expr (** Array access: a = arr[i] *) - | EFuncCall of expr * expr list (** Call of function: name(arguments) *) + | EFuncCall of expr * expr list (** Call of function: name(arguments) *) (* TODO: args *) | EAwait of expr (** [Await] expression *) [@@deriving eq, show { with_path = false }] diff --git a/CSharpStrange/lib/common.ml b/CSharpStrange/lib/common.ml new file mode 100644 index 00000000..0eb7ae91 --- /dev/null +++ b/CSharpStrange/lib/common.ml @@ -0,0 +1,32 @@ +open Ast + +module Id = struct + type t = ident + + let compare = compare +end + +module IdMap = Map.Make (Id) + +type obj_content = (* TODO *) + | VarType of var_type + | Method of field + | Field of field +[@@deriving show { with_path = false }, eq] + +type context = + | TCClass of c_sharp_class + +module TypeCheck = struct + type global_env = context IdMap.t + type local_env = obj_content IdMap.t + type curr_class = ident + type class_with_main = ident + + type state = + global_env + * local_env + * curr_class option + * _type option + * class_with_main option +end \ No newline at end of file diff --git a/CSharpStrange/lib/dune b/CSharpStrange/lib/dune index 1fe37a66..618611b3 100644 --- a/CSharpStrange/lib/dune +++ b/CSharpStrange/lib/dune @@ -1,7 +1,7 @@ (library (name c_sharp_strange_lib) (public_name CSharpStrange.Lib) - (modules Ast Parser Prettyprinter) + (modules Ast Parser Prettyprinter Typecheck Monads Common) (libraries angstrom base) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_expect ppx_inline_test)) diff --git a/CSharpStrange/lib/monads.ml b/CSharpStrange/lib/monads.ml new file mode 100644 index 00000000..5064b108 --- /dev/null +++ b/CSharpStrange/lib/monads.ml @@ -0,0 +1,165 @@ +type tc_error = + | NotImplemented + | OccursCheck + | AccessError + | ImpossibleResult of string + | TypeMismatch + | OtherError of string +[@@deriving show { with_path = false }] +(* TODO!! *) + +type error = TCError of tc_error [@@deriving show { with_path = false }] + +module STATEERROR = struct + type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t + + let return : 'a -> ('st, 'a) t = fun x st -> st, Result.Ok x + let fail : 'a -> ('st, 'b) t = fun e st -> st, Result.Error e + + let ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t = + fun x f st -> + let st, x = x st in + match x with + | Result.Ok x -> f x st + | Result.Error e -> fail e st + ;; + + let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = fun x1 x2 -> x1 >>= fun _ -> x2 + + let ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t = + fun x1 x2 st -> + let st, x = x1 st in + match x with + | Result.Ok x -> return x st + | Result.Error _ -> x2 st + ;; + + let ( >>| ) : ('st, 'a) t -> ('a -> 'b) -> ('st, 'b) t = + fun x f st -> + let st, x = x st in + match x with + | Result.Ok x -> return (f x) st + | Result.Error e -> fail e st + ;; + + let lift2 : ('a -> 'b -> 'c) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t = + fun f a b -> a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b + ;; + + let lift3 + : ('a -> 'b -> 'c -> 'd) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t -> ('st, 'd) t + = + fun f a b c -> lift2 f a b >>= fun f -> c >>| f + ;; + + let read : ('st, 'st) t = fun st -> return st st + let write : 'st -> ('st, unit) t = fun new_st _ -> new_st, Result.Ok () + + let map : ('a -> ('st, 'b) t) -> 'a list -> ('st, 'b list) t = + fun f list -> + let f acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in + List.fold_left f (return []) list >>| List.rev + ;; + + let iter : ('a -> ('st, unit) t) -> 'a list -> ('st, unit) t = + fun f list -> + let f acc elem = acc *> f elem *> return () in + List.fold_left f (return ()) list + ;; + + let run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t = fun f st -> f st +end + +module TYPECHECK = struct + open Ast + open Common + open Common.TypeCheck + include STATEERROR + + type 'a t = (TypeCheck.state, 'a) STATEERROR.t + + let return_with_fail = function + | Some x -> return x + | None -> fail (TCError OccursCheck) + ;; + + let read_local : 'a IdMap.t t = + read + >>= function + | _, l, _, _, _ -> return l + ;; + + let read_local_el id f = read_local >>= fun l -> IdMap.find_opt id l |> f + let read_local_el_opt id = read_local_el id return + let read_local_el id = read_local_el id return_with_fail + + let write_local n_l = + read + >>= function + | g, _, n, m, main -> write (g, n_l, n, m, main) + ;; + + let write_local_el el_id el_ctx = + read_local >>= fun l -> write_local (IdMap.add el_id el_ctx l) + ;; + + let write_meth_type_opt t = + read + >>= function + | g, l, n, _, main -> write (g, l, n, t, main) + ;; + + let write_meth_type t = write_meth_type_opt (Some t) + + let read_global : 'a IdMap.t t = + read + >>= function + | g, _, _, _, _ -> return g + ;; + + let read_global_el id f = read_global >>= fun g -> IdMap.find_opt id g |> f + let read_global_el_opt id = read_global_el id return + let read_global_el id = read_global_el id return_with_fail + + let read_meth_type : _type option t = + read + >>= function + | _, _, _, m_t, _ -> return m_t + ;; + + let read_main_class : class_with_main option t = + read + >>= function + | _, _, _, _, main -> return main + ;; + + let write_main_class main = + read + >>= function + | g, l, n, t, _ -> write (g, l, n, t, main) + ;; + + let write_global n_g = + read + >>= function + | _, l, n, m, main -> write (n_g, l, n, m, main) + ;; + + let write_global_el el_id el_ctx = + read_global >>= fun g -> write_global (IdMap.add el_id el_ctx g) + ;; + + let get_curr_class_name : curr_class t = + read + >>= function + | _, _, Some n, _, _ -> return n + | _ -> + fail (TCError (ImpossibleResult "Current class can be 'none' only before running")) + ;; + + let write_curr_class_name n = + read + >>= function + | g, l, _, t, main -> write (g, l, Some n, t, main) + ;; +end diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml new file mode 100644 index 00000000..786ac6e2 --- /dev/null +++ b/CSharpStrange/lib/typecheck.ml @@ -0,0 +1,303 @@ +open Ast +open Monads.TYPECHECK +open Common + +let value_to_type = function + | ValInt _ -> TypeInt + | ValChar _ -> TypeChar + | ValBool _ -> TypeBool + | ValString _ -> TypeString + | ValNull -> TypeInt (* TODO! *) +;; + +let vartype_to_type = function + | TypeVar t -> t +;; + +let vardecl_to_type = function + | Var (t, _) -> return (vartype_to_type t) +;; + +let name_to_obj_ctx n = read_local_el n + +let eq f e1 e2 = + match f e1 e2 with + | true -> return e1 + | false -> fail (TCError TypeMismatch) +;; + +let eq_type t1 t2 = eq equal__type t1 t2 +let eq_ident n1 n2 = eq equal_ident n1 n2 + +let eq_ident_return_ctx n1 n2 m f = + match equal_ident n1 n2 with + | true -> Some (f m) + | false -> None +;; + +let get_class_memb id memb = + match memb with + | VarField (_, _, f_id, _) -> eq_ident_return_ctx f_id id memb (fun f -> Field f) + | Method (_, _, m_id, _, _) -> eq_ident_return_ctx m_id id memb (fun m -> Method m) +;; + +let get_class_name = function + | Class (_, id, _) -> id +;; + +let find_memb_from_obj obj_id id = + let find_memb b id f = List.find_map (f id) b in + let find_class_memb b id = find_memb b id get_class_memb in + read_global_el obj_id + >>= function + | TCClass (Class (_, _, b)) -> find_class_memb b id |> return +;; + +let is_public obj_id ctx mds = + let is_m_public = function + | MPublic -> return (Some ctx) + | _ -> fail (TCError NotImplemented) + in + let rec is_m_list_public = function + | [] -> + read_global_el obj_id + >>= (function + | TCClass _ -> fail (TCError AccessError)) + | x :: xs -> + is_m_public x + >>= (function + | Some ctx -> return ctx + | None -> is_m_list_public xs) + (* TODO: bad code! *) + in + is_m_list_public mds +;; + +let find_obj_memb_with_fail n_obj n_mem = + find_memb_from_obj n_obj n_mem + >>= function + | Some memb -> + (match memb with + | Field (VarField (mds, _, _, _)) -> is_public n_obj memb mds + | Method (Method (mds, _, _, _, _)) -> is_public n_obj memb mds + | _ -> + fail + (TCError + (ImpossibleResult "Object can only have fields, constructors and methods"))) + | None -> fail (TCError (OtherError "Member not found")) +;; + +let find_memb_type = function + | VarType (TypeVar t) + | Field (VarField (_, TypeVar t, _, _)) + | Field (Method (_, t, _, _, _)) -> return t + | _ -> fail (TCError TypeMismatch) +;; + +let typecheck_method_args (Params params) args expr_tc = + let params_to_list_of_type p = + List.map + (function + | Var (t, _) -> vartype_to_type t) + p + in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in + let compare_two_lists l1 l2 eq rez = + match List.compare_lengths l1 l2 with + | 0 -> + (match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) + | _ -> fail (TCError (OtherError "Method invocation check error")) + in + args_to_list_of_type args + >>= fun args -> + compare_two_lists (params_to_list_of_type params) args equal__type params +;; + +let find_expr_type e expr_tc = expr_tc e >>= fun e -> find_memb_type e + +let typecheck_bin_op b e1 e2 expr_tc = + let compare_two_expr_type e1 e2 = + find_expr_type e1 expr_tc + >>= fun e1 -> find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 + in + let compare_three_expr_type e1 e2 t = + compare_two_expr_type e1 e2 >>= fun e -> eq_type e t + in + let return_rez rez = return (VarType (TypeVar rez)) in + match b with + | OpAdd | OpMul | OpSub | OpDiv | OpMod -> + compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeInt) + | OpLess | OpLessEqual | OpMore | OpMoreEqual -> + compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeBool) + | OpEqual | OpNonEqual -> compare_two_expr_type e1 e2 *> return_rez (TypeBase TypeBool) + | OpAnd | OpOr -> + compare_three_expr_type e1 e2 (TypeBase TypeBool) *> return_rez (TypeBase TypeBool) + | OpAssign -> + find_expr_type e1 expr_tc >>= fun e -> compare_two_expr_type e1 e2 *> return_rez e +;; + +let typecheck_un_op u e expr_tc = + let tc_un_op u e = + find_expr_type e expr_tc + >>= fun t -> + match u with + | OpNot -> eq_type t (TypeBase TypeBool) + in + tc_un_op u e >>= fun t -> return (VarType (TypeVar t)) +;; + +(* TODO const *) +(* TODO: redo funccal!!! *) +let typecheck_expr = + let rec tc_expr_ = function + | EId n -> name_to_obj_ctx n + | EFuncCall (e, params) -> fail (TCError NotImplemented) + | EBinOp (b, e1, e2) -> typecheck_bin_op b e1 e2 tc_expr_ + | EUnOp (u, e) -> typecheck_un_op u e tc_expr_ + | _ -> fail (TCError NotImplemented) + in + tc_expr_ +;; + +let typecheck_expr_with_type e = typecheck_expr e >>= fun x -> find_memb_type x +let eq_type_with_expr t e = typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t + +let save_decl n ctx = + read_local_el_opt n + >>= function + | None -> write_local_el n ctx + | Some _ -> fail (TCError (OtherError "This variable is already declared")) +;; + +let apply_local f = read_local >>= fun old_l -> f *> write_local old_l + +let rec typecheck_stmt = + let is_expr_bool e = + typecheck_expr_with_type e >>= fun t -> eq_type t (TypeBase TypeBool) + in + let typecheck_stmt_expr expr = + match expr with + | EFuncCall (e, args) -> + (* TODO FuncCall!! *) + typecheck_expr e + >>= (function + | Method (Method (_, TypeVoid, _, pms, _)) -> + typecheck_method_args pms args typecheck_expr *> return () + | _ -> fail (TCError TypeMismatch)) + | EBinOp (OpAssign, _, _) -> typecheck_expr expr *> return () + | _ -> fail (TCError TypeMismatch) + in + let typecheck_decl t n = function + | Some e -> eq_type_with_expr t e *> save_decl n (VarType (TypeVar t)) *> return () + | None -> save_decl n (VarType (TypeVar t)) *> return () + in + let typecheck_return e_opt = + read_meth_type + >>= fun m_t -> + match m_t, e_opt with + | Some TypeVoid, None -> return () + | Some (TypeBase t), Some e -> + (eq_type_with_expr (TypeBase t) e + <|> fail (TCError (OtherError "Returned type does not match the function type"))) + *> return () + | _ -> fail (TCError TypeMismatch) + in + let opt_unpack f = function + | None -> return () + | Some s -> f s *> return () + in + let typecheck_for_state init cond iter = + let typecheck_init = function + | None -> return () + | Some (SDecl (Var (TypeVar t, n), e)) -> typecheck_decl t n e + | _ -> fail (TCError TypeMismatch) + in + let typecheck_cond = opt_unpack is_expr_bool cond in + let typecheck_iter = opt_unpack typecheck_stmt_expr iter in + lift3 (fun _ _ _ -> ()) (typecheck_init init) typecheck_cond typecheck_iter + in + let typecheck_if_state cond b s_opt tc_st = + let typecheck_cond = is_expr_bool cond in + let typecheck_state = function + | Some st -> tc_st st + | None -> return () + in + lift3 (fun _ _ _ -> ()) typecheck_cond (tc_st b) (typecheck_state s_opt) + in + function + | SExpr expr -> typecheck_stmt_expr expr + | SDecl (Var (TypeVar t, n), e) -> typecheck_decl t n e + | SReturn e -> typecheck_return e + | SWhile (e, s) -> apply_local (is_expr_bool e *> typecheck_stmt s) + | SFor (init, cond, iter, b) -> + apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) + | SIf (e, b, s_opt) -> apply_local (typecheck_if_state e b s_opt typecheck_stmt) + | SBlock st_l -> apply_local (iter typecheck_stmt st_l) + | SBreak | SContinue -> fail (TCError NotImplemented) +;; + +let tc_member mem = + let tc_class_field f_type = function + | Some e -> eq_type_with_expr (vartype_to_type f_type) e *> return () + | None -> return () + in + let save_params_to_l (Params params) = + let f = function + | Var (t, n) -> write_local_el n (VarType t) + in + iter f params + in + let tc_meth typ params body = + apply_local (write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) + in + let tc_class_method (mds, tp, id, pms, b) = + match equal_ident id (Id "Main") with + | true -> + (match mds, pms, tp with + | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> + tc_meth tp (Params []) b *> read_main_class + >>= (function + | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) + | Some _ -> fail (TCError (OtherError "Main method already exists"))) + | _, _, _ -> + fail + (TCError + (OtherError + "Main must be a static method, have no params and return only int and \ + void"))) + | false -> tc_meth tp pms b + in + match mem with + | VarField (_, tp, _, e_opt) -> tc_class_field tp e_opt + | Method (mds, tp, id, pms, b) -> tc_class_method (mds, tp, id, pms, b) +;; + +let save_global id ctx = + read_global_el_opt id + >>= function + | None -> write_global_el id ctx + | Some _ -> fail (TCError (OtherError "This variable is already declared")) +;; + +let typecheck_obj cl = + let write_mems b = + let f mem = + match mem with + | VarField (_, _, id, _) -> save_decl id (Field mem) + | Method (_, _, id, _, _) -> save_decl id (Method mem) + in + iter f b + in + let tc_mems b = iter tc_member b in + let save_class cl = save_global (get_class_name cl) (TCClass cl) in + match cl with + | Class (mds, id, b) -> + write_curr_class_name id + *> apply_local (write_mems b *> save_class cl *> tc_mems b) + *> return () +;; + +(* TODO: parse CSharpClass?? *) +let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) From cd45e7b577eb55fd448b2ba9a635a1c0024510de Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Tue, 14 Oct 2025 13:58:59 +0300 Subject: [PATCH 20/84] feat: added REPL for parser + interpreter Signed-off-by: f1i3g3 --- CSharpStrange/bin/REPL.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml index 26d45ea3..26916050 100644 --- a/CSharpStrange/bin/REPL.ml +++ b/CSharpStrange/bin/REPL.ml @@ -1,19 +1,25 @@ open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Parser +open C_sharp_strange_lib.Interpret +open C_sharp_strange_lib.Common open Printf open Stdio type opts = { mutable dump_parse_tree : bool ; mutable file_path : string option + ; mutable eval : bool } let () = - let opts = { dump_parse_tree = false; file_path = None } in + let opts = { dump_parse_tree = false; file_path = None; eval = false } in let _ = Arg.parse [ "-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n" - ; "-filepath", Arg.String (fun file_path -> opts.file_path <- Some file_path), "\n" + ; ( "-filepath" + , Arg.String (fun file_path -> opts.file_path <- Some file_path) + , "Input code in file\n" ) + ; "-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n" ] (fun _ -> Stdlib.Format.eprintf "Something got wrong\n"; @@ -26,6 +32,12 @@ let () = | Some path -> String.trim @@ In_channel.read_all path in match apply_parser parse_prog path with - | Ok ast -> if opts.dump_parse_tree then print_endline (show_program ast) + | Ok ast -> + if opts.dump_parse_tree then print_endline (show_prog ast); + if opts.eval + then ( + match interpret prog with + | Ok (_, rez) -> print_endline (show_vl rez) + | Error msg -> failwith (sprintf "Interpretation error: %s" msg)) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) ;; From dc230bb50d4a2168b6b74e34f8251e0c6b395f81 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Tue, 14 Oct 2025 14:39:59 +0300 Subject: [PATCH 21/84] fix: strings renaming Signed-off-by: f1i3g3 --- CSharpStrange/lib/typecheck.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 786ac6e2..94ca214c 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -83,8 +83,8 @@ let find_obj_memb_with_fail n_obj n_mem = | _ -> fail (TCError - (ImpossibleResult "Object can only have fields, constructors and methods"))) - | None -> fail (TCError (OtherError "Member not found")) + (ImpossibleResult "Object can only have fields and methods"))) + | None -> fail (TCError (OtherError "Class member not found")) ;; let find_memb_type = function @@ -265,7 +265,7 @@ let tc_member mem = fail (TCError (OtherError - "Main must be a static method, have no params and return only int and \ + "Main must be a static method, have no params and return only int or \ void"))) | false -> tc_meth tp pms b in @@ -301,3 +301,7 @@ let typecheck_obj cl = (* TODO: parse CSharpClass?? *) let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) + +let typecheck_main prog = + typecheck prog |> fun ((_, _, _, _, main), res) -> main, res +;; From 63acde1286167ac152d8f777b45364dae346d60c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Tue, 14 Oct 2025 17:16:33 +0300 Subject: [PATCH 22/84] feat: add all what i have (still not finished) Signed-off-by: f1i3g3 --- CSharpStrange/bin/REPL.ml | 4 + CSharpStrange/lib/ast.ml | 5 +- CSharpStrange/lib/common.ml | 114 ++++++++- CSharpStrange/lib/common.mli | 150 ++++++++++++ CSharpStrange/lib/dune | 2 +- CSharpStrange/lib/interpret.ml | 305 ++++++++++++++++++++++++ CSharpStrange/lib/monads.ml | 208 +++++++++++++++- CSharpStrange/lib/parser.ml | 6 +- CSharpStrange/lib/prettyprinter.ml | 3 +- CSharpStrange/lib/typecheck.ml | 52 +++- CSharpStrange/lib/typecheck.mli | 10 + CSharpStrange/tests/dune | 2 +- CSharpStrange/tests/interpret_tests.ml | 142 +++++++++++ CSharpStrange/tests/interpret_tests.mli | 3 + CSharpStrange/tests/parser_tests.ml | 16 +- CSharpStrange/tests/typecheck_tests.ml | 194 +++++++++++++++ CSharpStrange/tests/typecheck_tests.mli | 3 + 17 files changed, 1170 insertions(+), 49 deletions(-) create mode 100644 CSharpStrange/lib/common.mli create mode 100644 CSharpStrange/lib/interpret.ml create mode 100644 CSharpStrange/lib/typecheck.mli create mode 100644 CSharpStrange/tests/interpret_tests.ml create mode 100644 CSharpStrange/tests/interpret_tests.mli create mode 100644 CSharpStrange/tests/typecheck_tests.ml create mode 100644 CSharpStrange/tests/typecheck_tests.mli diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml index 26916050..42fdfde6 100644 --- a/CSharpStrange/bin/REPL.ml +++ b/CSharpStrange/bin/REPL.ml @@ -1,3 +1,7 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Parser open C_sharp_strange_lib.Interpret diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index b2c05850..b07fb786 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -40,7 +40,6 @@ type modifier = type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] type params = Params of var_decl list [@@deriving eq, show { with_path = false }] -(* TODO: ?? *) (** Binary operations *) type bin_op = @@ -74,10 +73,12 @@ type expr = | EUnOp of un_op * expr (** Unary operation *) | EId of ident (** Identificator expression *) | EArrayAccess of expr * expr (** Array access: a = arr[i] *) - | EFuncCall of expr * expr list (** Call of function: name(arguments) *) (* TODO: args *) + | EFuncCall of expr * args (** Call of function: name(arguments) *) (* TODO: args *) | EAwait of expr (** [Await] expression *) [@@deriving eq, show { with_path = false }] +and args = Args of expr list [@@deriving show { with_path = false }] + (** Language statements *) type stmt = | SFor of stmt option * expr option * expr option * stmt diff --git a/CSharpStrange/lib/common.ml b/CSharpStrange/lib/common.ml index 0eb7ae91..10775380 100644 --- a/CSharpStrange/lib/common.ml +++ b/CSharpStrange/lib/common.ml @@ -1,5 +1,33 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open Ast +type tc_error = + | NotImplemented + | OccursCheck + | AccessError + | ImpossibleResult of string + | TypeMismatch + | OtherError of string +[@@deriving show { with_path = false }] + +type interpret_error = + | NotImplemented + | NoVariable of string + | AddressNotFound of int + | VarDeclared of string + | TypeMismatch + | ImpossibleResult of string + | OtherError of string +[@@deriving show { with_path = false }] + +type error = + | TCError of tc_error + | IError of interpret_error +[@@deriving show { with_path = false }] + module Id = struct type t = ident @@ -8,14 +36,24 @@ end module IdMap = Map.Make (Id) -type obj_content = (* TODO *) +type adr = Adr of int [@@deriving show { with_path = false }] + +module Adr = struct + type t = adr + + let compare = compare +end + +module AdrMap = Map.Make (Adr) + +type obj_content = + (* TODO *) | VarType of var_type | Method of field | Field of field [@@deriving show { with_path = false }, eq] -type context = - | TCClass of c_sharp_class +type context = TCClass of c_sharp_class module TypeCheck = struct type global_env = context IdMap.t @@ -24,9 +62,67 @@ module TypeCheck = struct type class_with_main = ident type state = - global_env - * local_env - * curr_class option - * _type option - * class_with_main option -end \ No newline at end of file + global_env * local_env * curr_class option * _type option * class_with_main option +end + +module Interpret = struct + type idx = Idx of int [@@deriving show { with_path = false }] + + (* TODO: proper records! *) + type meth = + { m_modifiers : modifier list + ; m_type : _type + ; m_id : ident + ; m_params : params + } + [@@deriving show { with_path = false }, eq] + + type constr = + { c_modifier : modifier list + ; c_id : ident + ; c_params : params + } + [@@deriving show { with_path = false }, eq] + + type code = + | IConstructor of constr * stmt + | IMethod of meth * stmt + [@@deriving show { with_path = false }, eq] + (* TODO: proper records! *) + + type class_ = + { cl_modifiers : modifier list + ; cl_id : ident + ; cl_body : code list + } + [@@deriving show { with_path = false }, eq] + + type el = + | IClass of adr + | IValue of val_type + [@@deriving show { with_path = false }] + + type vl = + | Init of el + | NotInit + [@@deriving show { with_path = false }] + + type local_el = + | Code of code + | Value of vl * idx option + + type local_env = idx (* new idx *) * local_el IdMap.t + + type obj = + { mems : (field * vl) IdMap.t + ; cl_name : ident + ; p_adr : adr option + ; inh_adr : adr option + } + + type context = IntrClass of class_ [@@deriving show { with_path = false }] + type memory = adr * obj AdrMap.t + type local_adr = adr + type global_env = context IdMap.t + type state = global_env * local_env * local_adr * memory +end diff --git a/CSharpStrange/lib/common.mli b/CSharpStrange/lib/common.mli new file mode 100644 index 00000000..69c22a39 --- /dev/null +++ b/CSharpStrange/lib/common.mli @@ -0,0 +1,150 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast + +type tc_error = + | NotImplemented + | OccursCheck + | AccessError + | ImpossibleResult of string + | TypeMismatch + | OtherError of string + +val pp_tc_error : Format.formatter -> tc_error -> unit +val show_tc_error : tc_error -> string + +type interpret_error = + | NotImplemented + | NoVariable of string + | AddressNotFound of int + | VarDeclared of string + | TypeMismatch + | ImpossibleResult of string + | OtherError of string + +val pp_interpret_error : Format.formatter -> interpret_error -> unit +val show_interpret_error : interpret_error -> string + +type error = + | TCError of tc_error + | IError of interpret_error + +val pp_error : Format.formatter -> error -> unit +val show_error : error -> string + + +module Id : sig + type t = ident + val compare : 't -> 't -> int +end + +module IdMap : sig + include Map.S with type key = Ast.ident +end + +type adr = Adr of int + +val pp_adr : Format.formatter -> adr -> unit +val show_adr : adr -> string + +module Adr : sig + type t = adr + val compare : 't -> 't -> int +end + +module AdrMap : sig + include Map.S with type key = adr +end + +type obj_content = + | VarType of Ast.var_type + | Method of Ast.field + | Field of Ast.field + +val pp_obj_content : Format.formatter -> obj_content -> unit +val show_obj_content : obj_content -> string +val equal_obj_content : obj_content -> obj_content -> bool + +type context = TCClass of c_sharp_class + +module TypeCheck : sig + type global_env = context IdMap.t + type local_env = obj_content IdMap.t + type curr_class = ident + type class_with_main = ident + + type state = + global_env * local_env * curr_class option * _type option * class_with_main option +end + +module Interpret : sig + type idx = Idx of int + + val pp_idx : Format.formatter -> idx -> unit + val show_idx : idx -> string + + type meth = { + m_modifiers : modifier list; + m_type : _type; + m_id : ident; + m_params : params; + } + + type constr = { + c_modifier : modifier list; + c_id : ident; + c_params : params; + } + + type code = + | IConstructor of constr * stmt + | IMethod of meth * stmt + + val pp_code : Format.formatter -> code -> unit + val show_code : code -> string + + type class_ = { + cl_modifiers : modifier list; + cl_id : ident; + cl_body : code list; + } + + type el = + | IClass of adr + | IValue of val_type + + val pp_el : Format.formatter -> el -> unit + val show_el : el -> string + + type vl = + | Init of el + | NotInit + + val pp_vl : Format.formatter -> vl -> unit + val show_vl : vl -> string + + type local_el = + | Code of code + | Value of vl * idx option + + type local_env = idx * local_el IdMap.t + + type obj = { + mems : (field * vl) IdMap.t; + cl_name : ident; + p_adr : adr option; + inh_adr : adr option; + } + + type context = IntrClass of class_ + + val pp_context : Format.formatter -> context -> unit + val show_context : context -> string + + type memory = adr * obj AdrMap.t + type local_adr = adr + type global_env = context IdMap.t + type state = global_env * local_env * local_adr * memory +end diff --git a/CSharpStrange/lib/dune b/CSharpStrange/lib/dune index 618611b3..e97b2f57 100644 --- a/CSharpStrange/lib/dune +++ b/CSharpStrange/lib/dune @@ -1,7 +1,7 @@ (library (name c_sharp_strange_lib) (public_name CSharpStrange.Lib) - (modules Ast Parser Prettyprinter Typecheck Monads Common) + (modules Ast Parser Prettyprinter Typecheck Monads Common Interpret) (libraries angstrom base) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_expect ppx_inline_test)) diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange/lib/interpret.ml new file mode 100644 index 00000000..a06bb4af --- /dev/null +++ b/CSharpStrange/lib/interpret.ml @@ -0,0 +1,305 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open Parser +open Typecheck +open Common +open Common.Interpret +open Monads.INTERPRT + +let is_val = function + | Value (x, _) -> return x + | _ -> fail (IError (OtherError "It's not a value")) +;; + +let is_init x = + is_val x + >>= function + | Init x -> return x + | _ -> fail (IError (OtherError "Value is not initialized")) +;; + +let is_init_val x = + is_val x + >>= function + | Init (IValue x) -> return x + | _ -> fail (IError (OtherError "Value is not initialized")) +;; + +let is_code = function + | Code c -> return c + | _ -> fail (IError (OtherError "It's not a method")) +;; + +let is_int x = + is_init_val x + >>= function + | ValInt x -> return x + | _ -> fail (IError TypeMismatch) +;; + +let is_bool x = + is_init_val x + >>= function + | ValBool x -> return x + | _ -> fail (IError TypeMismatch) +;; + +let v_int x = ValInt x +let v_bool x = ValBool x +let v_bool_not x = ValBool (not x) +let v_int_minus x = ValInt (-x) +let interpret_const c = return (Value (Init (IValue c), None)) (* TODO *) +let interpret_id n = find_local_el n + +let interpret_func_call args i_expr code i_stmt = + (* TODO *) + let get_args = map i_expr args in + is_code code + >>= function + | IMethod (m, body) -> + read_local_adr + >>= fun adr -> + get_args >>= fun args -> run_method args m.m_params adr m.m_type (i_stmt body) + | IConstructor _ -> + fail (IError (OtherError "Multiple constructors are not implemented")) +;; + +let i_assign e1 e2 i_expr = + let is_val_with_idx = function + | Value (_, i) -> return i + | _ -> + fail + (IError (OtherError "The assignment operator must assign a value to the variable")) + in + i_expr e2 + >>= is_init + >>= fun v -> + match e1 with + | EId n -> + (read_local + >>= (fun (idx, l) -> + read_local_el n + >>= is_val_with_idx + >>= fun i -> write_local (idx, IdMap.add n (Value (Init v, i)) l)) + <|> (read_local_adr + >>= fun adr -> + read_memory_obj adr + >>= fun obj -> + IdMap.find_opt n obj.mems + |> function + | Some (f, _) -> + write_memory_obj adr { obj with mems = IdMap.add n (f, Init v) obj.mems } + | None -> fail (IError TypeMismatch))) + *> find_local_el n + | _ -> + fail + (IError (OtherError "The assignment operator must assign a value to the variable")) +;; + +let i_bin_op bin_op e1 e2 i_expr = + let r_val op v f = + lift2 (fun e1 e2 -> e1, e2) (i_expr e1 >>= f) (i_expr e2 >>= f) + >>= fun (c1, c2) -> return (Value (Init (IValue (v (op c1 c2))), None)) + in + let int_r_int op = r_val op v_int is_int in + let int_r_bool op = r_val op v_bool is_int in + let bool_r_bool op = r_val op v_bool is_bool in + let not_equal_val_type c1 c2 = + equal_val_type c1 c2 + |> function + | true -> false + | false -> true + in + let eq op = r_val op v_bool is_init_val in + match bin_op with + | OpAdd -> int_r_int ( + ) + | OpMul -> int_r_int ( * ) + | OpSub -> int_r_int ( - ) + | OpDiv -> int_r_int ( / ) + | OpMod -> int_r_int ( mod ) + | OpEqual -> eq equal_val_type + | OpNonEqual -> eq not_equal_val_type + | OpLess -> int_r_bool ( < ) + | OpLessEqual -> int_r_bool ( <= ) + | OpMore -> int_r_bool ( > ) + | OpMoreEqual -> int_r_bool ( >= ) + | OpAnd -> bool_r_bool ( && ) + | OpOr -> bool_r_bool ( || ) + | OpAssign -> i_assign e1 e2 i_expr +;; + +let i_un_op un_op e i_expr i_stmt = + let res f v = i_expr e >>= f >>= fun x -> interpret_const (v x) in + match un_op with + | OpNot -> res is_bool v_bool_not +;; + +let i_expr i_statement = + let check_return = function + | Some x -> return (Value (x, None)) + | None -> fail (IError (OtherError "Void cannot be used with expr")) + in + let rec i_expr_ = function + | EId n -> interpret_id n + | EBinOp (bin_op, e1, e2) -> i_bin_op bin_op e1 e2 i_expr_ + | EUnOp (un_op, e) -> i_un_op un_op e i_expr_ i_statement + | EFuncCall (e, Args args) -> + (match e with + | EId n -> + interpret_id n + >>= fun el -> interpret_func_call args i_expr_ el i_statement >>= check_return + | _ -> fail (IError (ImpossibleResult "Check during typecheck"))) + | _ -> fail (IError NotImplemented) + in + i_expr_ +;; + +let i_stmt_expr expr i_expr i_stmt = + (* TODO !!!!!!!!!!! *) + match expr with + | EFuncCall (e, Args args) -> + i_expr e + >>= fun code -> + i_method_invoke args i_expr code i_stmt + >>= (function + | None -> return () + | Some _ -> + fail (IError (OtherError "The statement can only have a method of void type"))) + | EBinOp (OpAssign, _, _) -> i_expr expr *> return () + | _ -> fail (IError TypeMismatch) +;; + +let bool_expr i_stmt e = i_expr i_stmt e >>= is_bool + +let i_if_state i_stmt e b s_opt = + bool_expr i_stmt e + >>= function + | true -> i_stmt b + | false -> + (match s_opt with + | Some b -> i_stmt b + | None -> return ()) +;; + +let rec cycle f1 f2 = + f1 + >>= function + | true -> f2 *> cycle f1 f2 + | false -> return () +;; + +let i_while_state i_stmt e s = cycle (bool_expr i_stmt e) (i_stmt s) + +let i_for_state i_stmt init cond iter b = + let get_init = + match init with + | Some init -> i_stmt init + | None -> return () + in + let get_cond = + match cond, iter with + | Some c, Some i -> i_expr i_stmt i *> bool_expr i_stmt c + | Some c, None -> bool_expr i_stmt c + | None, Some i -> i_expr i_stmt i *> return true + | None, None -> return true + in + get_init *> cycle get_cond (i_stmt b) +;; + +let local f = + let helper idx k v acc = + match v with + | Value (v, Some (Idx cur_idx)) -> + (match cur_idx <= idx with + | true -> IdMap.add k (Value (v, Some (Idx cur_idx))) acc + | false -> acc) + | Code c -> IdMap.add k (Code c) acc + | _ -> acc + in + read_local + >>= fun (Idx i, _) -> + f *> read_local + >>= fun (_, l) -> write_local (Idx i, IdMap.fold (helper i) l IdMap.empty) +;; + +let interpret_stmt = + let rec i_stmt = function + | SExpr e -> i_sexpr e (i_expr i_stmt) i_stmt + | SDecl (Var (TypeVar _, n), e) -> + get_new_idx + >>= fun new_idx -> + (match e with + | Some e -> + i_expr i_stmt e + >>= (function + | Value (v, _) -> write_new_local_el n (Value (v, Some new_idx)) + | _ -> fail (IError (ImpossibleResult "Check during typecheck"))) + | None -> write_new_local_el n (Value (NotInit, Some new_idx))) + | SReturn e -> + (match e with + | Some e -> i_expr i_stmt e >>= is_val >>= fun r -> func_return (Some r) + | None -> func_return None) + | SWhile (e, s) -> local (i_while_state i_stmt e s) + | SFor (init, cond, iter, b) -> local (i_for_state i_stmt init cond iter b) + | SIf (e, b, s_opt) -> local (i_if_state i_stmt e b s_opt) + | SBlock st_l -> local (iter i_stmt st_l) + | SBreak | SContinue -> fail (IError NotImplemented) + in + i_stmt +;; + +let get_meth_from_class cl name = + let f acc = function + | IMethod (m, b) when equal_name m.m_name name -> return (Some (m, b)) + | _ -> return acc + in + fold_left f None cl.cl_body +;; + +let run_interpreter cl_with_main g_env = + let get_g_env = + let f = function + | IntrClass cl -> write_global_el cl.cl_id (IntrClass cl) + in + f g_env + in + let get_l_env = + let save_constr cl = + write_new_local_el + cl.cl_name + (Code + (IConstructor + ( { c_modifier = [ MPublic ]; c_id = cl.cl_id; c_params = Params [] } + , SBlock [] ))) + <|> return () + in + let f = + match cl with + | Class _ -> save_constr cl + in + f g_env + in + get_g_env *> get_l_env *> read_global_el cl_with_main + >>= function + | _ -> fail (IError NotImplemented) +;; + +let interpret str = + match apply_parser parse_prog str with + | Result.Ok (Program pr) -> + (match typecheck_main pr with + | Some cl_with_main, Result.Ok _ -> + run (run_interpreter cl_with_main pr) + |> (function + | _, Signal (Pipe x) -> Result.Ok x + | _, IError er -> Result.Error er + | _, _ -> + Result.Error (IError (ImpossibleResult "Run_method returns return or error"))) + | None, Result.Ok _ -> Result.Error (IError (OtherError "Main method not found")) + | _, Result.Error er -> Result.Error er) + | Result.Error e -> Result.Error (TCError (OtherError e)) +;; +(* TODO: not finished, should add more combinators *) diff --git a/CSharpStrange/lib/monads.ml b/CSharpStrange/lib/monads.ml index 5064b108..0e3a12d3 100644 --- a/CSharpStrange/lib/monads.ml +++ b/CSharpStrange/lib/monads.ml @@ -1,14 +1,8 @@ -type tc_error = - | NotImplemented - | OccursCheck - | AccessError - | ImpossibleResult of string - | TypeMismatch - | OtherError of string -[@@deriving show { with_path = false }] -(* TODO!! *) - -type error = TCError of tc_error [@@deriving show { with_path = false }] +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common module STATEERROR = struct type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t @@ -72,7 +66,6 @@ end module TYPECHECK = struct open Ast - open Common open Common.TypeCheck include STATEERROR @@ -163,3 +156,194 @@ module TYPECHECK = struct | g, l, _, t, main -> write (g, l, Some n, t, main) ;; end + +module INTERPRET = struct + open Ast + open Common + open Common.Interpret + + type ('a, 'r) runtime_signal = + | Pipe of 'a + | Return of 'r + + type ('a, 'r, 'e) result = + | Signal of ('a, 'r) runtime_signal + | IError of 'e + + type st = Common.Interpret.state + type ('a, 'r) t = st -> st * ('a, 'r, error) result + + let return : 'a -> ('a, 'r) t = fun x st -> st, Signal (Pipe x) + let fail : 'e -> ('a, 'r) t = fun er st -> st, IError er + let func_return : 'r -> ('a, 'r) t = fun x st -> st, Signal (Return x) + + let ( >>= ) : ('a, 'r) t -> ('a -> ('b, 'r) t) -> ('b, 'r) t = + fun x f st -> + let st, x = x st in + match x with + | Signal (Pipe x) -> f x st + | Signal (Return r) -> func_return r st + | IError er -> fail er st + ;; + + let ( <|> ) : ('a, 'r) t -> ('a, 'r) t -> ('a, 'r) t = + fun x1 x2 st -> + let st, x = x1 st in + match x with + | Signal (Pipe x) -> return x st + | IError _ -> x2 st + | Signal (Return r) -> func_return r st + ;; + + let ( >>| ) : ('a, 'r) t -> ('a -> 'b) -> ('b, 'r) t = + fun x f st -> + let st, x = x st in + match x with + | Signal (Pipe x) -> return (f x) st + | Signal (Return r) -> func_return r st + | IError er -> fail er st + ;; + + let ( *> ) : ('a, 'r) t -> ('b, 'r) t -> ('b, 'r) t = fun x1 x2 -> x1 >>= fun _ -> x2 + + let fold_left f acc l = + let foo acc a = acc >>= fun acc -> f acc a >>= return in + List.fold_left foo (return acc) l + ;; + + let map f list = + let f' acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in + List.fold_left f' (return []) list >>| List.rev + ;; + + let iter f list = + let foo acc el = acc *> f el *> return () in + List.fold_left foo (return ()) list + ;; + + let lift2 f a b = a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b + + let run : ('a, 'r) t -> st * ('a, 'r, error) result = + fun f -> f (IdMap.empty, (Idx 0, IdMap.empty), Adr 0, (Adr 0, AdrMap.empty)) + ;; + + let pipe_adr_with_fail (Adr a) = function + | Some x -> return x + | None -> fail (IError (AddressNotFound a)) + ;; + + let pipe_id_with_fail (Id n) = function + | Some x -> return x + | None -> fail (IError (NoVariable n)) + ;; + + let read : (st, 'r) t = fun st -> return st st + let write : st -> (unit, 'r) t = fun new_st _ -> new_st, Signal (Pipe ()) + + let read_local = + read + >>= function + | _, l, _, _ -> return l + ;; + + let read_local_el f name = read_local >>= fun (_, l) -> IdMap.find_opt name l |> f + let read_local_el_opt name = read_local_el return name + let read_local_el id = read_local_el (pipe_id_with_fail id) id + + let read_local_adr = + read + >>= function + | _, _, adr, _ -> return adr + ;; + + let read_memory = + read + >>= function + | _, _, _, m -> return m + ;; + + let read_memory_obj adr = + read_memory >>= fun (_, m) -> AdrMap.find_opt adr m |> pipe_adr_with_fail adr + ;; + + let write_memory n_m = + read + >>= function + | g, l, adr, _ -> write (g, l, adr, n_m) + ;; + + let write_memory_obj obj_adr obj_ctx = + read_memory >>= fun (adr, m) -> write_memory (adr, AdrMap.add obj_adr obj_ctx m) + ;; + + let write_local n_l = + read + >>= function + | g, _, adr, m -> write (g, n_l, adr, m) + ;; + + let write_local_el el_id el_ctx = + read_local >>= fun (idx, l) -> write_local (idx, IdMap.add el_id el_ctx l) + ;; + + let write_new_local_el (Id el_id) el_ctx = + read_local_el_opt (Id el_id) + >>= function + | Some _ -> fail (IError (VarDeclared el_id)) + | None -> write_local_el (Id el_id) el_ctx + ;; + + let read_global = + read + >>= function + | g, _, _, _ -> return g + ;; + + let read_global_el name = + read_global >>= fun g -> IdMap.find_opt name g |> pipe_id_with_fail name + ;; + + let write_global n_g = + read + >>= function + | _, l, adr, m -> write (n_g, l, adr, m) + ;; + + let write_global_el el_name el_ctx = + read_global >>= fun g -> write_global (IdMap.add el_name el_ctx g) + ;; + + let find_local_el id = + let rec find_memory_obj adr = + read_memory_obj adr + >>= fun obj -> + IdMap.find_opt id obj.mems + |> function + | Some (_, vl) -> return (Value (vl, None)) + | None -> + (match obj.p_adr with + | Some p_adr -> find_memory_obj p_adr + | None -> fail (IError TypeMismatch)) + in + let find_global_el adr = + let f acc = function + | IMethod (m, b) when equal_ident m.m_id id -> + return (Some (Code (IMethod (m, b)))) + | _ -> return acc + in + read_memory_obj adr + >>= fun obj -> + read_global_el obj.cl_name + >>= function + | IntrClass cl -> + fold_left f None cl.cl_body + >>= (function + | Some vl -> return vl + | None -> + (match id with + | Id n -> fail (IError (NoVariable n)))) + in + read_local_el id + <|> (read_local_adr >>= fun adr -> find_memory_obj adr <|> find_global_el adr) + ;; +end diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 9b001915..778bc4b0 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -175,11 +175,11 @@ let parse_id_expr = skip_spaces *> (parse_id >>| fun x -> EId x) <* skip_spaces let parse_call_id = parse_id_expr let parse_args_list arg = parens @@ sep_by (skip_spaces *> char ',') arg -let parse_call_args id arg = - parse_args_list arg >>= fun args -> return @@ EFuncCall (id, args) +let parse_call_args id (arg: expr t) = + parse_args_list arg >>= fun args -> return @@ EFuncCall (id, Args args) ;; -let parse_call_expr arg = parse_call_id >>= fun id -> parse_call_args id arg +let parse_call_expr (arg : expr t) = parse_call_id >>= fun id -> parse_call_args id arg (* Operations *) let parse_op op typ = skip_spaces *> string op *> return typ diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml index a8e971cf..bb441fc1 100644 --- a/CSharpStrange/lib/prettyprinter.ml +++ b/CSharpStrange/lib/prettyprinter.ml @@ -80,7 +80,8 @@ let rec pp_expr fmt = function | EUnOp (op, e) -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e | EId id -> pp_ident fmt id | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 - | EFuncCall (e, args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args + | EFuncCall (e, Args args) -> + fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args | EAwait e -> fprintf fmt "await %a" pp_expr e ;; diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 94ca214c..f3dd1dd1 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -1,3 +1,7 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open Ast open Monads.TYPECHECK open Common @@ -80,10 +84,7 @@ let find_obj_memb_with_fail n_obj n_mem = (match memb with | Field (VarField (mds, _, _, _)) -> is_public n_obj memb mds | Method (Method (mds, _, _, _, _)) -> is_public n_obj memb mds - | _ -> - fail - (TCError - (ImpossibleResult "Object can only have fields and methods"))) + | _ -> fail (TCError (ImpossibleResult "Object can only have fields and methods"))) | None -> fail (TCError (OtherError "Class member not found")) ;; @@ -94,7 +95,7 @@ let find_memb_type = function | _ -> fail (TCError TypeMismatch) ;; -let typecheck_method_args (Params params) args expr_tc = +let typecheck_method_args (Params params) (Args args) expr_tc = let params_to_list_of_type p = List.map (function @@ -148,12 +149,41 @@ let typecheck_un_op u e expr_tc = tc_un_op u e >>= fun t -> return (VarType (TypeVar t)) ;; -(* TODO const *) -(* TODO: redo funccal!!! *) +let tc_method_args (Params params) (Args args) expr_tc = + let params_to_list_of_type p = + List.map + (function + | Var (t, _) -> vartype_to_type t) + p + in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in + let compare_two_lists l1 l2 eq rez = + match List.compare_lengths l1 l2 with + | 0 -> + (match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) + | _ -> fail (TCError (OtherError "Method invocation check error")) + in + args_to_list_of_type args + >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params +;; +let tc_method_invoke e args expr_tc = + expr_tc e + >>= function + | Ast.Method (_, tp, _, pms, _) -> + tc_method_args pms args expr_tc + *> + (match tp with + | TypeBase _ -> return (VarType (TypeVar tp)) + | TypeVoid -> fail (TCError (OtherError "Method invocation check error"))) + | _ -> fail (TCError (OtherError "Method invocation check error")) +;; + let typecheck_expr = let rec tc_expr_ = function | EId n -> name_to_obj_ctx n - | EFuncCall (e, params) -> fail (TCError NotImplemented) + | EFuncCall (e, args) -> tc_method_invoke e args tc_expr_ | EBinOp (b, e1, e2) -> typecheck_bin_op b e1 e2 tc_expr_ | EUnOp (u, e) -> typecheck_un_op u e tc_expr_ | _ -> fail (TCError NotImplemented) @@ -299,9 +329,5 @@ let typecheck_obj cl = *> return () ;; -(* TODO: parse CSharpClass?? *) let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) - -let typecheck_main prog = - typecheck prog |> fun ((_, _, _, _, main), res) -> main, res -;; +let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res diff --git a/CSharpStrange/lib/typecheck.mli b/CSharpStrange/lib/typecheck.mli new file mode 100644 index 00000000..4da5842f --- /dev/null +++ b/CSharpStrange/lib/typecheck.mli @@ -0,0 +1,10 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open Monads.TYPECHECK +open Common + +val typecheck : c_sharp_class -> TypeCheck.state * (unit, error) result +val type_checker_with_main : c_sharp_class -> Ast.ident option * (unit, Common.error) result diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index f112a01f..92006902 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -1,7 +1,7 @@ (library (name tests) (public_name CSharpStrange.Lib.Tests) - (modules Parser_tests Pp_tests) + (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests) (libraries angstrom c_sharp_strange_lib) (inline_tests) (instrumentation diff --git a/CSharpStrange/tests/interpret_tests.ml b/CSharpStrange/tests/interpret_tests.ml new file mode 100644 index 00000000..ab49732e --- /dev/null +++ b/CSharpStrange/tests/interpret_tests.ml @@ -0,0 +1,142 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open C_sharp_strange_lib.Interpret +open C_sharp_strange_lib.Monad +open C_sharp_strange_lib.Common.Interpret + +let show_wrap str = + match interpret str with + | Result.Ok x -> + (match x with + | Some x -> Format.printf "Result: '%a'" pp_vl x + | None -> Format.print_string "Result: void\n") + | Result.Error er -> Format.printf "%a\n%!" pp_error er +;; + +let%expect_test _ = + show_wrap + {| + class Program { + int b = 9; + int c = 67; + int a; + bool r = false; + string s = "ok"; + char h = 'a'; + bool t; + + static int Main() { + a = (50 % 2) + b - c; + r = s != "kkkk" && (190%22 == 100 * -2/5); + t = (a != b * c) || (a >= b) && (a == c +90); + return a; + } + } |}; + [%expect {| + Result: '(Init (IValue (VInt -58)))' |}] +;; + +let%expect_test _ = + show_wrap + {| + class Program { + int n = 10; + static int Main() { + int res = 0; + for(int i = 0; i < n; i = i+1) { + for(int j = 0; j < i; j = j+1) { + res = res + i *j; + } + } + return res; + } + } |}; + [%expect {| + Result: '(Init (IValue (VInt 870)))' |}] +;; + +let%expect_test _ = + show_wrap + {| + class Program { + bool t; + int a = 5; + + static int Main() { + int b = 5; + int c = 2; + t = true; + if (t) { + if (t && false) { + t = false; + return 1; + } + else if( a == b) { + a = c*67 + 7; + return a; + } + } + else { + return 3; + } + return 0; + } + } |}; + [%expect {| + Result: '(Init (IValue (VInt 141)))' |}] +;; + +let%expect_test _ = + show_wrap + {| + class Program { + int x = 189; + int s = 0; + static int Main() { + while (x != 0) { + s = s + x % 10; + x = x/ 10; + } + return s; + } + } |}; + [%expect {| + Result: '(Init (IValue (VInt 18)))' |}] +;; + +let%expect_test _ = + show_wrap + {| + class Program { + public int is_right_triangle(int a, int b, int c) { + if ((a + b <= c) || (a + c <= b) || (b + c <= a)) { + return 0; + } else if ((a * a + b * b == c * c) || (a * a + c * c == b * b) || (b * b + c * c == a * a)) { + return 1; + } else { + return 2; + } + } + static int Main() { + return is_right_triangle(3,4,5); + } + } |}; + [%expect {| + Result: '(Init (IValue (VInt 1)))' |}] +;; + + +let%expect_test _ = + show_wrap + {| + class Program { + static int Main() { + int a; + int b = a -1 + 4; + return b; + } + } |}; + [%expect {| (Interpret_error (Other "Value is not initialized")) |}] +;; diff --git a/CSharpStrange/tests/interpret_tests.mli b/CSharpStrange/tests/interpret_tests.mli new file mode 100644 index 00000000..71f70320 --- /dev/null +++ b/CSharpStrange/tests/interpret_tests.mli @@ -0,0 +1,3 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) \ No newline at end of file diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index bcc62dba..34646bd5 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -300,8 +300,9 @@ let%test "Parse method 3" = , EId (Id "n") , EFuncCall ( EId (Id "Factorial") - , [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) - ] ) ))) + , Args + [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) + ] ) ))) ]) ) ] )) ;; @@ -411,11 +412,12 @@ let%test "Parse factorial" = , EId (Id "n") , EFuncCall ( EId (Id "Factorial") - , [ EBinOp - ( OpSub - , EId (Id "n") - , EValue (ValInt 1) ) - ] ) ))) + , Args + [ EBinOp + ( OpSub + , EId (Id "n") + , EValue (ValInt 1) ) + ] ) ))) ]) ) ] ) ] ))) diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml new file mode 100644 index 00000000..9dcd8f5b --- /dev/null +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -0,0 +1,194 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open C_sharp_strange_lib.Typecheck +open C_sharp_strange_lib.Monads +open C_sharp_strange_lib.Parser +open C_sharp_strange_lib.Ast +open C_sharp_strange_lib.Common + +let show_wrap = function + | Some (Program x) -> + (match typecheck x with + | _, Result.Ok _ -> Format.print_string "Ok!\n" + | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) + | _ -> Format.print_string "Some error\n" +;; + +let print_tc p str = show_wrap (parse_option p str) +let test_ast = print_tc parse_prog + +let%expect_test _ = + test_ast + {| + class Program { + int Fac(int num) { + if (num == 1) { + return 1; + } + else + { + return num * Fac(num - 1); + } + } + static int Main() { + return Fac(5); + } + } |}; + [%expect {| + Ok! |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + int Fac(int num) { + if (num == 1) { + return "one"; + } + } + } |}; + [%expect + {| + (Typecheck_error (Other "Returned type does not match the function type")) |}] +;; + +let%expect_test _ = + test_ast {| + class Program { + int a = 5; + int b = 9; + int a = 9; + } |}; + [%expect {| + (Typecheck_error (Other "This variable is already declared")) |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + int b = 9; + int c = b * 67; + int a = (50 % 2) + b - c; + bool r = (a != b * c) || (a >= b) && (a == c +90); + string s = "ok"; + char h = 'a'; + + void M() { + a = 5; + r = s != "kkkk" && (190%22 == 100 * -2/5); + } + } |}; + [%expect {| + Ok! |}] +;; + +let%expect_test _ = + test_ast {| + class Program { + string a = "5"; + int c = 9 + a; + } |}; + [%expect {| + (Typecheck_error TypeMismatch) |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + static int Main() { + int counter = 0; + bool b = true; + while(true) { + if (count != 2) { + count = count + 1; + b = b && false; + } + else if (b == false){ + return -1; + } + else { + return 0; + } + } + } + } |}; + [%expect {| + Ok! |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + int n = 10; + int count = 7% 2*67; + static int Main() { + for (int i = 0; i < n; i=i+1) { + for (int j = 1;;) { + for (;j != n; j = j + 2) { + for (;;) { + count = count + i + j; + } + } + } + } + return count; + } + } |}; + [%expect {| + Ok! |}] +;; + +let%expect_test _ = + test_ast {| + class Program { + public virtual void Main() {} + } + |}; + [%expect + {| + (Typecheck_error + (Other + "Main must be a static method, have no params and return only int and void")) |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + void Test() {} + int a = 9; + void Test() {} + } |}; + [%expect {| + (Typecheck_error (Other "This variable is already declared")) |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + public void a(int n, int m){ + return n+m; + }; + }|}; + [%expect {| + (Typecheck_error TypeMismatch) |}] +;; + +let%expect_test _ = + test_ast + {| + class Program { + public void foo() { + bool a = new A(); + }; + }|}; + [%expect {| + (Typecheck_error Occurs_check) |}] +;; diff --git a/CSharpStrange/tests/typecheck_tests.mli b/CSharpStrange/tests/typecheck_tests.mli new file mode 100644 index 00000000..2a5ede90 --- /dev/null +++ b/CSharpStrange/tests/typecheck_tests.mli @@ -0,0 +1,3 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 525272ec4fa1c4ca93662598b28bf61bff945922 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 28 Feb 2026 17:11:55 +0300 Subject: [PATCH 23/84] fix: monad name fix Signed-off-by: f1i3g3 --- CSharpStrange/lib/interpret.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange/lib/interpret.ml index a06bb4af..d6becda2 100644 --- a/CSharpStrange/lib/interpret.ml +++ b/CSharpStrange/lib/interpret.ml @@ -7,7 +7,7 @@ open Parser open Typecheck open Common open Common.Interpret -open Monads.INTERPRT +open Monads.INTERPRET let is_val = function | Value (x, _) -> return x From c41d9a10b33be71d5ceeb33cc25bf1031020e6b8 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 28 Feb 2026 17:55:19 +0300 Subject: [PATCH 24/84] fix(typecheck): many fixes, typecheck should compile now Signed-off-by: f1i3g3 --- CSharpStrange/lib/typecheck.ml | 18 ++++++++++++------ CSharpStrange/lib/typecheck.mli | 2 +- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index f3dd1dd1..a9cc540b 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -166,17 +166,23 @@ let tc_method_args (Params params) (Args args) expr_tc = | _ -> fail (TCError (OtherError "Method invocation check error")) in args_to_list_of_type args - >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params + >>= fun args -> + compare_two_lists (params_to_list_of_type params) args equal__type params ;; + let tc_method_invoke e args expr_tc = expr_tc e >>= function - | Ast.Method (_, tp, _, pms, _) -> + | Method (Ast.Method (_, tp, _, pms, _)) -> tc_method_args pms args expr_tc - *> - (match tp with - | TypeBase _ -> return (VarType (TypeVar tp)) - | TypeVoid -> fail (TCError (OtherError "Method invocation check error"))) + >>= fun _ -> + (match tp with + | TypeBase _ -> return (VarType (TypeVar tp)) + | TypeVoid -> + fail (TCError (OtherError "Void methods cannot be used in expressions"))) + | Field (Ast.VarField (_, _, _, _)) -> + fail (TCError (OtherError "Cannot call a field as a method")) + | VarType _ -> fail (TCError (OtherError "Cannot call a variable as a method")) | _ -> fail (TCError (OtherError "Method invocation check error")) ;; diff --git a/CSharpStrange/lib/typecheck.mli b/CSharpStrange/lib/typecheck.mli index 4da5842f..35579d9a 100644 --- a/CSharpStrange/lib/typecheck.mli +++ b/CSharpStrange/lib/typecheck.mli @@ -7,4 +7,4 @@ open Monads.TYPECHECK open Common val typecheck : c_sharp_class -> TypeCheck.state * (unit, error) result -val type_checker_with_main : c_sharp_class -> Ast.ident option * (unit, Common.error) result +val typecheck_main : c_sharp_class -> Ast.ident option * (unit, Common.error) result From 20e961f9d6ae30b81a005fba87855ce4b6a4cc5b Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 28 Feb 2026 17:55:51 +0300 Subject: [PATCH 25/84] fix(typecheck): some changes in tests Signed-off-by: f1i3g3 --- CSharpStrange/tests/typecheck_tests.ml | 40 +++++++++++++++++--------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml index 9dcd8f5b..6cd6dd10 100644 --- a/CSharpStrange/tests/typecheck_tests.ml +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -40,6 +40,8 @@ let%expect_test _ = Ok! |}] ;; +(* TODO: funccall! *) + let%expect_test _ = test_ast {| @@ -52,9 +54,11 @@ let%expect_test _ = } |}; [%expect {| - (Typecheck_error (Other "Returned type does not match the function type")) |}] + (TCError (OtherError "Returned type does not match the function type")) |}] ;; +(* TODO: funccall! *) + let%expect_test _ = test_ast {| class Program { @@ -63,7 +67,7 @@ let%expect_test _ = int a = 9; } |}; [%expect {| - (Typecheck_error (Other "This variable is already declared")) |}] + (TCError (OtherError "This variable is already declared")) |}] ;; let%expect_test _ = @@ -86,6 +90,8 @@ let%expect_test _ = Ok! |}] ;; +(* TODO: parser check! *) + let%expect_test _ = test_ast {| class Program { @@ -93,9 +99,11 @@ let%expect_test _ = int c = 9 + a; } |}; [%expect {| - (Typecheck_error TypeMismatch) |}] + (TCError TypeMismatch) |}] ;; +(* TODO: string! *) + let%expect_test _ = test_ast {| @@ -121,6 +129,8 @@ let%expect_test _ = Ok! |}] ;; +(* TODO: ????! *) + let%expect_test _ = test_ast {| @@ -144,6 +154,8 @@ let%expect_test _ = Ok! |}] ;; +(* TODO: some stuff here! *) + let%expect_test _ = test_ast {| class Program { @@ -152,11 +164,13 @@ let%expect_test _ = |}; [%expect {| - (Typecheck_error - (Other + (TCError + (OtherError "Main must be a static method, have no params and return only int and void")) |}] ;; +(* TODO: formatting???! *) + let%expect_test _ = test_ast {| @@ -166,7 +180,7 @@ let%expect_test _ = void Test() {} } |}; [%expect {| - (Typecheck_error (Other "This variable is already declared")) |}] + (TCError (OtherError "This variable is already declared")) |}] ;; let%expect_test _ = @@ -178,17 +192,15 @@ let%expect_test _ = }; }|}; [%expect {| - (Typecheck_error TypeMismatch) |}] + (TCError TypeMismatch) |}] ;; +(* TODO: check formatting??!*) -let%expect_test _ = - test_ast - {| +(* TODO: occurs check: smth like + {| class Program { public void foo() { bool a = new A(); }; - }|}; - [%expect {| - (Typecheck_error Occurs_check) |}] -;; + }|} +*) From 2afff6344ad16c94988a8e92fcbfe0e611cb24ac Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 2 Mar 2026 23:12:29 +0300 Subject: [PATCH 26/84] docs: updated dune-project Signed-off-by: f1i3g3 --- CSharpStrange/dune-project | 1 + 1 file changed, 1 insertion(+) diff --git a/CSharpStrange/dune-project b/CSharpStrange/dune-project index dba4e1cb..a526a062 100644 --- a/CSharpStrange/dune-project +++ b/CSharpStrange/dune-project @@ -20,6 +20,7 @@ (description "An interpreter for subset of C# language with async/await and LINQ (and some other stuff which will be added later)") ; TODO: actual documentation (documentation "https://kakadu.github.io/fp2024/docs/Lambda") + ; TODO: update old links (version 0.1) (depends dune From d589bd6d6c9fee53beceaae6a42f047d6c3c44a3 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 2 Mar 2026 23:21:53 +0300 Subject: [PATCH 27/84] fix: restored dune file Signed-off-by: f1i3g3 --- CSharpStrange/dune | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 CSharpStrange/dune diff --git a/CSharpStrange/dune b/CSharpStrange/dune new file mode 100644 index 00000000..98e54536 --- /dev/null +++ b/CSharpStrange/dune @@ -0,0 +1,7 @@ +(env + (dev + (flags + (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) + (release + (flags + (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) From 485b0ae4df3e780b3be50e55af42ac5e9aed1896 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Thu, 5 Mar 2026 14:55:06 +0300 Subject: [PATCH 28/84] feat(tests): added QCheck tests Signed-off-by: f1i3g3 --- CSharpStrange/tests/dune | 4 +- CSharpStrange/tests/qt_tests.ml | 297 ++++++++++++++++++++++++++++++++ 2 files changed, 299 insertions(+), 2 deletions(-) create mode 100644 CSharpStrange/tests/qt_tests.ml diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index 92006902..5c193b44 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -1,8 +1,8 @@ (library (name tests) (public_name CSharpStrange.Lib.Tests) - (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests) - (libraries angstrom c_sharp_strange_lib) + (modules Parser_tests Pp_tests Typecheck_tests Qt_tests) + (libraries angstrom c_sharp_strange_lib qcheck) (inline_tests) (instrumentation (backend bisect_ppx)) diff --git a/CSharpStrange/tests/qt_tests.ml b/CSharpStrange/tests/qt_tests.ml new file mode 100644 index 00000000..e6350f64 --- /dev/null +++ b/CSharpStrange/tests/qt_tests.ml @@ -0,0 +1,297 @@ +(* TODO: refactor + add to README *) + +open C_sharp_strange_lib +open QCheck +open Ast +open Parser + +(* Ast generators *) +let gen_ident = + let open Gen in + map + (fun s -> if List.mem s Parser.reserved then Id "x" else Id s) + string_small + +let gen_ident_length len = + let open Gen in + let char_gen = char_range 'a' 'z' in + let char_list_gen = list_size (return len) char_gen in + map + (fun chars -> + let s = String.of_seq (List.to_seq chars) in + if List.mem s Parser.reserved then Id "x" else Id s) + char_list_gen + +let gen_val_type = + let open Gen in + oneof + [ + map (fun i -> ValInt i) int; + map (fun c -> ValChar c) (char_range 'a' 'z'); + map (fun b -> ValBool b) bool; + map (fun s -> ValString s) string_small; + return ValNull; + ] + +let gen_binop = + let open Gen in + oneof + [ + return OpAdd; + return OpSub; + return OpMul; + return OpDiv; + return OpMod; + return OpEqual; + return OpNonEqual; + return OpLess; + return OpMore; + return OpLessEqual; + return OpMoreEqual; + return OpAnd; + return OpOr; + return OpAssign; + ] + +let gen_unop = Gen.return OpNot + +let rec gen_expr depth = + let open Gen in + if depth <= 0 then + (* no recursion *) + oneof + [ + map (fun v -> EValue v) gen_val_type; + map (fun id -> EId id) (gen_ident_length 5); + ] + else + let sub = gen_expr (depth - 1) in + frequency + [ + (4, sub); + (2, map2 (fun op (l, r) -> EBinOp (op, l, r)) gen_binop (pair sub sub)); + (1, map2 (fun op e -> EUnOp (op, e)) gen_unop sub); + ( 1, + map2 + (fun f args -> EFuncCall (f, Args args)) + sub + (list_size (1 -- 3) sub) ); + ] + +let rec gen_stmt depth = + let open Gen in + if depth <= 0 then + oneof + [ + map (fun e -> SExpr e) (gen_expr 2); + map2 + (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) + gen_ident (gen_expr 2); + ] + else + let sub_stmt = gen_stmt (depth - 1) in + frequency + [ + (3, map (fun e -> SExpr e) (gen_expr depth)); + ( 2, + map2 + (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) + gen_ident (gen_expr depth) ); + ( 1, + map3 + (fun cond t e -> SIf (cond, t, e)) + (gen_expr depth) sub_stmt (option sub_stmt) ); + ( 1, + map2 (fun cond body -> SWhile (cond, body)) (gen_expr depth) sub_stmt + ); + (1, map (fun stmts -> SBlock stmts) (list_size (1 -- 5) sub_stmt)); + (1, map (fun e -> SReturn (Some e)) (gen_expr depth)); + ] + +(* Shrinkers *) + +let ( <+> ) = Iter.append + +let shrink_ident (Id s) = + let open Iter in + if String.length s > 1 then return (Id (String.sub s 0 (String.length s - 1))) + else empty + +let shrink_val_type = function + | ValInt i -> Iter.map (fun i -> ValInt i) (Shrink.int i) + | ValString s -> Iter.map (fun s -> ValString s) (Shrink.string s) + | ValChar _ -> Iter.return ValNull + | ValBool b -> if b then Iter.return (ValBool false) else Iter.empty + | ValNull -> Iter.empty + +let rec shrink_expr = function + | EValue v -> Iter.map (fun v' -> EValue v') (shrink_val_type v) + | EId id -> Iter.map (fun id' -> EId id') (shrink_ident id) + | EBinOp (op, l, r) -> + let open Iter in + return l <+> return r + <+> map (fun l' -> EBinOp (op, l', r)) (shrink_expr l) + <+> map (fun r' -> EBinOp (op, l, r')) (shrink_expr r) + | EUnOp (op, e) -> + Iter.return e <+> Iter.map (fun e' -> EUnOp (op, e')) (shrink_expr e) + | EFuncCall (f, Args []) -> Iter.return f + | EFuncCall (f, Args args) -> ( + let open Iter in + return (EFuncCall (f, Args [])) + <+> map (fun f' -> EFuncCall (f', Args args)) (shrink_expr f) + <+> + match args with + | arg :: rest -> + map (fun arg' -> EFuncCall (f, Args (arg' :: rest))) (shrink_expr arg) + <+> return (EFuncCall (f, Args rest)) + | [] -> empty) + | EArrayAccess _ -> Iter.empty + | EAwait _ -> Iter.empty + +let rec compare_expr_structure e1 e2 = + match (e1, e2) with + | EValue v1, EValue v2 -> ( + match (v1, v2) with + | ValInt _, ValInt _ -> true + | ValChar _, ValChar _ -> true + | ValBool _, ValBool _ -> true + | ValString _, ValString _ -> true + | ValNull, ValNull -> true + | _ -> false) + | EId _, EId _ -> true + | EBinOp (op1, l1, r1), EBinOp (op2, l2, r2) -> + op1 = op2 && compare_expr_structure l1 l2 && compare_expr_structure r1 r2 + | EUnOp (op1, e1), EUnOp (op2, e2) -> + op1 = op2 && compare_expr_structure e1 e2 + | EFuncCall (f1, Args a1), EFuncCall (f2, Args a2) -> + compare_expr_structure f1 f2 && List.length a1 = List.length a2 + | _ -> false + +let add_random_whitespace s = + let len = String.length s in + let buf = Buffer.create (len * 2) in + for i = 0 to len - 1 do + (* TODO: proper constant *) + if Random.int 5 = 0 then Buffer.add_char buf ' '; + Buffer.add_char buf s.[i]; + if Random.int 5 = 0 then Buffer.add_char buf ' ' + done; + Buffer.contents buf + +let expr_arbitrary depth = + let gen = gen_expr depth in + let shrink = shrink_expr in + QCheck.make ~shrink gen + +let stmt_arbitrary depth = + let gen = gen_stmt depth in + QCheck.make gen (* TODO: shrink для stmt *) + +let print_expr out expr = output_string out (Ast.show_expr expr) +(* TODO: Pp *) + +let test_count = 10 + +(* Correct parser work *) +let prop_parse_no_crash = + Test.make ~name:"parser does not crash on valid expressions" ~count:test_count + (expr_arbitrary 5) (fun expr -> + let str = Ast.show_expr expr in + match Parser.apply_parser Parser.parse_ops str with + | Ok _ -> true + | Error e -> + Printf.printf "\nParse error (but no crash): %s\n%s\n" str e; + true) + +(* Roundtrip: show -> parse -> show *) +let prop_roundtrip_expr = + let gen = expr_arbitrary 5 in + Test.make ~name:"expression roundtrip: show -> parse -> show" + ~count:(test_count / 2) gen (fun expr -> + let str1 = Ast.show_expr expr in + match Parser.apply_parser Parser.parse_ops str1 with + | Ok expr' -> + let str2 = Ast.show_expr expr' in + if str1 = str2 then true + else ( + Printf.eprintf "\nRoundtrip failed:\n"; + Printf.eprintf "Original: %s\n" str1; + Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); + Printf.eprintf "Roundtrip:%s\n" str2; + false) + | Error e -> + Printf.eprintf "\nParse failed in roundtrip: %s\n%s\n" str1 e; + false) + +(* Operators priority tests *) +let prop_operator_precedence = + let gen = expr_arbitrary 3 in + Test.make ~name:"operator precedence is preserved" ~count:(test_count / 2) gen + (fun expr -> + let str = Ast.show_expr expr in + match Parser.apply_parser Parser.parse_ops str with + | Ok expr' -> + if compare_expr_structure expr expr' then true + else ( + Printf.eprintf "\nPrecision failed:\n"; + Printf.eprintf "Original: %s\n" (Ast.show_expr expr); + Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); + false) + | Error e -> + Printf.eprintf "\nParse failed: %s\n" str; + false) + +(* Stmt tests *) +let prop_stmt_no_crash = + Test.make ~name:"statement parser does not crash" ~count:(test_count / 2) + (stmt_arbitrary 3) (fun stmt -> + let str = Ast.show_stmt stmt in + (* временно, пока нет отдельного парсера утверждений *) + true) + +(* Correct space pacing *) +let prop_whitespace_handling = + let gen = expr_arbitrary 3 in + Test.make ~name:"parser handles whitespace correctly" ~count:(test_count / 5) + gen (fun expr -> + let base_str = Ast.show_expr expr in + let spaced_str = add_random_whitespace base_str in + match + ( Parser.apply_parser Parser.parse_ops base_str, + Parser.apply_parser Parser.parse_ops spaced_str ) + with + | Ok expr1, Ok expr2 -> + if compare_expr_structure expr1 expr2 then true + else ( + Printf.eprintf "\nWhitespace handling failed:\n"; + Printf.eprintf "Original (no spaces): %s\n" base_str; + Printf.eprintf "With spaces: %s\n" spaced_str; + Printf.eprintf "Parsed (no spaces): %s\n" (Ast.show_expr expr1); + Printf.eprintf "Parsed (with spaces): %s\n" (Ast.show_expr expr2); + false) + | _ -> false) + +(* Test run *) +let () = + Random.self_init (); + + Printf.printf "\nQUICKCHECK TESTS\n\n"; + + let tests = + [ + prop_parse_no_crash; + prop_roundtrip_expr; + prop_operator_precedence; + prop_stmt_no_crash; + prop_whitespace_handling; + ] + in + + Printf.printf "Run %d tests...\n" (List.length tests); + + let exit_code = QCheck_runner.run_tests ~verbose:true tests in + + Printf.printf "\nRESULTS\n"; + + if exit_code = 0 then Printf.printf "All tests are executed!\n" + else Printf.printf "Some tests are not executed! (code: %d).\n" exit_code From a7af59429962fb669b274a7587afde844fb19ebb Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Thu, 5 Mar 2026 20:43:13 +0300 Subject: [PATCH 29/84] fix(tests): tests fixes Signed-off-by: f1i3g3 --- CSharpStrange/tests/qt_tests.ml | 28 +++++++++++++------------- CSharpStrange/tests/typecheck_tests.ml | 1 - 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/CSharpStrange/tests/qt_tests.ml b/CSharpStrange/tests/qt_tests.ml index e6350f64..5f8192f4 100644 --- a/CSharpStrange/tests/qt_tests.ml +++ b/CSharpStrange/tests/qt_tests.ml @@ -9,7 +9,7 @@ open Parser let gen_ident = let open Gen in map - (fun s -> if List.mem s Parser.reserved then Id "x" else Id s) + (fun s -> if List.mem s reserved then Id "x" else Id s) string_small let gen_ident_length len = @@ -19,7 +19,7 @@ let gen_ident_length len = map (fun chars -> let s = String.of_seq (List.to_seq chars) in - if List.mem s Parser.reserved then Id "x" else Id s) + if List.mem s reserved then Id "x" else Id s) char_list_gen let gen_val_type = @@ -194,10 +194,10 @@ let test_count = 10 (* Correct parser work *) let prop_parse_no_crash = - Test.make ~name:"parser does not crash on valid expressions" ~count:test_count + Test.make ~name:"Parser does not crash on valid expressions" ~count:test_count (expr_arbitrary 5) (fun expr -> let str = Ast.show_expr expr in - match Parser.apply_parser Parser.parse_ops str with + match apply_parser Parser.parse_ops str with | Ok _ -> true | Error e -> Printf.printf "\nParse error (but no crash): %s\n%s\n" str e; @@ -206,10 +206,10 @@ let prop_parse_no_crash = (* Roundtrip: show -> parse -> show *) let prop_roundtrip_expr = let gen = expr_arbitrary 5 in - Test.make ~name:"expression roundtrip: show -> parse -> show" + Test.make ~name:"Expression roundtrip: show -> parse -> show" ~count:(test_count / 2) gen (fun expr -> let str1 = Ast.show_expr expr in - match Parser.apply_parser Parser.parse_ops str1 with + match apply_parser Parser.parse_ops str1 with | Ok expr' -> let str2 = Ast.show_expr expr' in if str1 = str2 then true @@ -226,10 +226,10 @@ let prop_roundtrip_expr = (* Operators priority tests *) let prop_operator_precedence = let gen = expr_arbitrary 3 in - Test.make ~name:"operator precedence is preserved" ~count:(test_count / 2) gen + Test.make ~name:"Operator precedence is preserved" ~count:(test_count / 2) gen (fun expr -> let str = Ast.show_expr expr in - match Parser.apply_parser Parser.parse_ops str with + match apply_parser Parser.parse_ops str with | Ok expr' -> if compare_expr_structure expr expr' then true else ( @@ -237,28 +237,28 @@ let prop_operator_precedence = Printf.eprintf "Original: %s\n" (Ast.show_expr expr); Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); false) - | Error e -> + | Error _ -> Printf.eprintf "\nParse failed: %s\n" str; false) (* Stmt tests *) let prop_stmt_no_crash = - Test.make ~name:"statement parser does not crash" ~count:(test_count / 2) + Test.make ~name:"Statement parser does not crash" ~count:(test_count / 2) (stmt_arbitrary 3) (fun stmt -> let str = Ast.show_stmt stmt in - (* временно, пока нет отдельного парсера утверждений *) + (*TODO: stmt parser *) true) (* Correct space pacing *) let prop_whitespace_handling = let gen = expr_arbitrary 3 in - Test.make ~name:"parser handles whitespace correctly" ~count:(test_count / 5) + Test.make ~name:"Parser handles whitespace correctly" ~count:(test_count / 5) gen (fun expr -> let base_str = Ast.show_expr expr in let spaced_str = add_random_whitespace base_str in match - ( Parser.apply_parser Parser.parse_ops base_str, - Parser.apply_parser Parser.parse_ops spaced_str ) + ( apply_parser parse_ops base_str, + apply_parser parse_ops spaced_str ) with | Ok expr1, Ok expr2 -> if compare_expr_structure expr1 expr2 then true diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml index 6cd6dd10..88a9ab91 100644 --- a/CSharpStrange/tests/typecheck_tests.ml +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -3,7 +3,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Typecheck -open C_sharp_strange_lib.Monads open C_sharp_strange_lib.Parser open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Common From b17558d35c4cd4d86caa1f5f9506f0ca9c8772ed Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 16:47:26 +0300 Subject: [PATCH 30/84] fix(parser): parser fixes Signed-off-by: f1i3g3 --- CSharpStrange/lib/parser.ml | 300 +++++++++----------- CSharpStrange/lib/parser.mli | 1 + CSharpStrange/tests/parser_tests.ml | 426 +++++++++++++++------------- 3 files changed, 366 insertions(+), 361 deletions(-) diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 778bc4b0..0223a2bb 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -10,104 +10,80 @@ open Base let chainl0 expr op = op >>= (fun op1 -> expr >>| op1) <|> expr let chainl1 expr op = - let rec pars e1 = lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 in + let rec pars e1 = + lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 + in expr >>= pars -;; let chainr1 expr op = - fix (fun x -> lift2 (fun op1 -> op1) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) -;; + fix (fun x -> + lift2 (fun op1 -> op1) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) (* Special functions *) let reserved = - [ "true" - ; "false" - ; "if" - ; "else" - ; "while" - ; "public" - ; "static" - ; "void" - ; "string" - ; "char" - ; "int" - ; "bool" - ; "for" - ; "null" - ; "new" - ; "return" - ; "break" - ; "continue" - ; "class" - ; "async" - ; "await" + [ + "true"; + "false"; + "if"; + "else"; + "while"; + "public"; + "static"; + "void"; + "string"; + "char"; + "int"; + "bool"; + "for"; + "null"; + "new"; + "return"; + "break"; + "continue"; + "class"; + "async"; + "await"; ] -;; let in_reserved t = List.mem reserved t ~equal:String.equal - -let is_space = function - | ' ' | '\t' | '\n' | '\r' -> true - | _ -> false -;; +let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false let is_token_sym = function | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '_' -> true | _ -> false -;; let skip_spaces = skip_while is_space - -let parens p = - skip_spaces *> (char '(' <|> fail "<(> error)") *> p - <* skip_spaces - <* (char ')' <|> fail "<)> error)") -;; - -let braces p = - skip_spaces *> (char '{' <|> fail "<{> error)") *> p - <* skip_spaces - <* (char '}' <|> fail "<}> error)") -;; - -let brackets p = - skip_spaces *> (char '[' <|> fail "<[> error)") *> p - <* skip_spaces - <* (char ']' <|> fail "<]> error)") -;; - -let skip_semicolons = fix (fun f -> skip_spaces *> char ';' *> f <|> return "") +let parens p = skip_spaces *> char '(' *> p <* skip_spaces <* char ')' +let braces p = skip_spaces *> char '{' *> p <* skip_spaces <* char '}' +let brackets p = skip_spaces *> char '[' *> p <* skip_spaces <* char ']' +let skip_semicolons = fix (fun f -> skip_spaces *> char ';' *> f <|> return ()) let skip_semicolons1 = skip_spaces *> char ';' *> skip_semicolons (* Values *) let parse_int = - take_while1 Char.is_digit - >>= fun num -> return @@ ValInt (Int.of_string num) <|> fail "Not an int" -;; + take_while1 Char.is_digit >>= fun num -> + return @@ ValInt (Int.of_string num) <|> fail "Not an int" let parse_char = char '\'' *> any_char <* char '\'' >>= (fun c -> return @@ ValChar c) <|> fail "Not a char" -;; let parse_bool = choice - [ string "true" *> return (ValBool true); string "false" *> return (ValBool false) ] + [ + string "true" *> return (ValBool true); + string "false" *> return (ValBool false); + ] <|> fail "Not a bool" -;; let parse_val_string = - char '\"' - *> take_till (function - | '\"' -> true - | _ -> false) + char '\"' *> take_till (function '\"' -> true | _ -> false) <* char '\"' >>= (fun s -> return @@ ValString s) <|> fail "Not a string" -;; let parse_null = string "null" *> return ValNull <|> fail "Not a null" @@ -116,70 +92,63 @@ let parse_null = string "null" *> return ValNull <|> fail "Not a null" let parse_modifiers = many (choice - [ string "public" *> skip_spaces *> return MPublic - ; string "static" *> skip_spaces *> return MStatic - ; string "async" *> skip_spaces *> return MAsync + [ + string "public" *> skip_spaces *> return MPublic; + string "static" *> skip_spaces *> return MStatic; + string "async" *> skip_spaces *> return MAsync; ]) - <|> fail "Modifier error" -;; (* Type words *) let parse_type_word = - take_while is_token_sym - >>= function + take_while is_token_sym >>= function | "int" -> return TypeInt | "char" -> return TypeChar | "bool" -> return TypeBool | "string" -> return TypeString | _ -> fail "Wrong type word" -;; let parse_base_type = parse_type_word >>= fun tp -> return @@ TypeBase tp let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x let parse_value = choice - [ val_to_expr parse_bool - ; val_to_expr parse_char - ; val_to_expr parse_int - ; val_to_expr parse_null - ; val_to_expr parse_val_string + [ + val_to_expr parse_bool; + val_to_expr parse_char; + val_to_expr parse_int; + val_to_expr parse_null; + val_to_expr parse_val_string; ] <|> fail "Value error" -;; let parse_id = - take_while is_token_sym - >>= fun str -> - match not (String.is_empty str || in_reserved str || Char.is_digit str.[0]) with - | true -> return (Id str) - | _ -> fail "Not an identifier" -;; + take_while1 is_token_sym >>= fun str -> + if String.is_empty str || in_reserved str || Char.is_digit str.[0] then + fail "Not an identifier" + else return (Id str) (* Expressions *) (* Variables && functions *) let parse_var_type = - choice ?failure_msg:(Some "Incorrect type") [ parse_base_type ] - >>= fun x -> return (TypeVar x) -;; + choice ?failure_msg:(Some "Incorrect type") [ parse_base_type ] >>= fun x -> + return (TypeVar x) let parse_var = let parse_decl_id typ_ = - char ' ' *> skip_spaces *> parse_id >>| fun id -> Var (typ_, id) + skip_spaces *> parse_id >>| fun id -> Var (typ_, id) in skip_spaces *> parse_var_type >>= parse_decl_id -;; let parse_id_expr = skip_spaces *> (parse_id >>| fun x -> EId x) <* skip_spaces let parse_call_id = parse_id_expr let parse_args_list arg = parens @@ sep_by (skip_spaces *> char ',') arg -let parse_call_args id (arg: expr t) = +let parse_call_args id (arg : expr t) = parse_args_list arg >>= fun args -> return @@ EFuncCall (id, Args args) -;; -let parse_call_expr (arg : expr t) = parse_call_id >>= fun id -> parse_call_args id arg +let parse_call_expr (arg : expr t) = + parse_call_id >>= fun id -> parse_call_args id arg (* Operations *) let parse_op op typ = skip_spaces *> string op *> return typ @@ -207,21 +176,27 @@ let ( ^!^ ) = parse_un_op "!" OpNot let parse_ops = fix (fun expr -> - let lv1 = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in - let lv2 = chainl0 lv1 (choice [ ( ^!^ ) ]) in - let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in - let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in - let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in - let lv6 = chainl1 lv5 (choice [ ( ^==^ ); ( ^!=^ ) ]) in - let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in - let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in - chainr1 lv8 (choice [ ( ^=^ ) ])) + let lv1 = + choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] + in + let lv2 = + many (choice [ ( ^!^ ) ]) >>= fun ops -> + lv1 >>= fun e -> + return (List.fold_right ops ~f:(fun op acc -> op acc) ~init:e) + in + (* TODO: rewrite somehow + more ops *) + let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in + let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in + let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in + let lv6 = chainl1 lv5 (choice [ ( ^==^ ); ( ^!=^ ) ]) in + let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in + let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in + chainr1 lv8 (choice [ ( ^=^ ) ])) <|> fail "Expr error" -;; let parse_assign = - lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops <|> fail "Assign error" -;; + lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops + <|> fail "Assign error" (* Statements *) @@ -232,27 +207,26 @@ let parse_decl = (fun dcl e -> SDecl (dcl, e)) parse_var (option None (skip_spaces *> char '=' *> parse_ops >>| fun e -> Some e)) -;; let expr_to_stmt expr = expr >>| fun x -> SExpr x -let parse_stmt_ops = expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] + +let parse_stmt_ops = + expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] let parse_if_else f_if_body = let parse_if_cond = string "if" *> skip_spaces *> parens parse_ops in let parse_else_cond ifls body = skip_spaces - *> (get_opt @@ (string "else" *> skip_spaces *> choice [ ifls; body ]) <|> return None) + *> (get_opt @@ (string "else" *> skip_spaces *> choice [ ifls; body ]) + <|> return None) in fix (fun ifls -> - let parse_body = f_if_body <|> (parse_stmt_ops <* skip_semicolons1) in - let parse_else_body = parse_else_cond ifls parse_body in - lift3 - (fun cond if_body else_body -> SIf (cond, if_body, else_body)) - parse_if_cond - parse_body - parse_else_body) + let parse_body = f_if_body <|> (parse_stmt_ops <* skip_semicolons1) in + let parse_else_body = parse_else_cond ifls parse_body in + lift3 + (fun cond if_body else_body -> SIf (cond, if_body, else_body)) + parse_if_cond parse_body parse_else_body) <|> fail "If error" -;; let parse_for body = let expr_to_option_stmt expr = get_opt @@ expr_to_stmt expr in @@ -266,22 +240,21 @@ let parse_for body = (fun (f_init_p, f_cond_p, f_iter_p) f_body -> SFor (f_init_p, f_cond_p, f_iter_p, f_body)) (parens - @@ lift3 - (fun init cond incr -> init, cond, incr) - (p_for_init <* skip_spaces <* char ';') - (p_for_expr <* skip_spaces <* char ';') - p_for_expr) + @@ lift3 + (fun init cond incr -> (init, cond, incr)) + (p_for_init <* skip_spaces <* char ';') + (p_for_expr <* skip_spaces <* char ';') + p_for_expr) p_body in string "for" *> p_for <|> fail "For error" -;; let parse_while body = let p_body = body <|> skip_semicolons1 *> parse_stmt_ops in let p_cond = parens parse_ops in let p_while = string "while" *> skip_spaces *> p_cond in - lift2 (fun cond body -> SWhile (cond, body)) p_while p_body <|> fail "While error" -;; + lift2 (fun cond body -> SWhile (cond, body)) p_while p_body + <|> fail "While error" let parse_return = lift2 @@ -289,105 +262,94 @@ let parse_return = (string "return") (parse_ops >>= (fun ret -> return (Some ret)) <|> return None) <|> fail "Return error" -;; -let parse_break = skip_spaces *> string "break" *> return SBreak <|> fail "Break error" +let parse_break = + skip_spaces *> string "break" *> return SBreak <|> fail "Break error" let parse_continue = skip_spaces *> string "continue" *> return SContinue <|> fail "Continue error" -;; let parse_block = fix (fun block -> - let sc p = p <* skip_semicolons1 in - let op_sc p = p <* skip_semicolons in - let body_step = - choice - ?failure_msg:(Some "Error in some block sentence") - [ sc parse_decl - ; sc parse_break - ; sc parse_continue - ; sc parse_return - ; sc parse_stmt_ops - ; op_sc @@ parse_if_else block - ; op_sc @@ parse_for block - ; op_sc @@ parse_while block - ] - in - braces (skip_semicolons *> many (skip_spaces *> body_step)) - >>= fun stmt_lst -> return @@ SBlock stmt_lst) -;; + let sc p = p <* skip_semicolons1 in + let op_sc p = p <* skip_semicolons in + + let body_step = + choice ?failure_msg:(Some "Error in some block sentence") + [ + sc parse_decl; + sc parse_break; + sc parse_continue; + sc parse_return; + sc parse_stmt_ops; + op_sc @@ parse_if_else block; + op_sc @@ parse_for block; + op_sc @@ parse_while block; + ] + in + braces (skip_semicolons *> many (skip_spaces *> body_step)) + >>= fun stmt_lst -> return @@ SBlock stmt_lst) (* Program class functions *) let parse_field_sign = let f_value = skip_spaces *> char '=' *> get_opt parse_ops in lift4 - (fun f_modif f_type f_id f_val -> f_modif, f_type, f_id, f_val) + (fun f_modif f_type f_id f_val -> (f_modif, f_type, f_id, f_val)) (skip_spaces *> parse_modifiers) (skip_spaces *> parse_var_type) - (skip_spaces *> parse_id) - (option None f_value) + (skip_spaces *> parse_id) (option None f_value) <* skip_semicolons1 -;; let parse_method_type = let parse_void = string "void" *> return TypeVoid in choice ?failure_msg:(Some "Not a method type") [ parse_base_type; parse_void ] -;; let parse_method_sign = let parse_args = - parens @@ sep_by (skip_spaces *> char ',' <* skip_spaces) parse_var + parens (sep_by (skip_spaces *> char ',' <* skip_spaces) parse_var) >>= fun exp -> return (Params exp) in lift4 - (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) + (fun m_modif m_type m_id m_params -> (m_modif, m_type, m_id, m_params)) (skip_spaces *> parse_modifiers) (skip_spaces *> parse_method_type) (skip_spaces *> parse_id) (skip_spaces *> parse_args) -;; let parse_method_member = lift2 (fun (mds, tp, id, ps) bd -> Method (mds, tp, id, ps, bd)) - parse_method_sign - parse_block -;; + parse_method_sign parse_block let parse_field_member = - parse_field_sign - >>| function - | mds, tp, id, Some ex -> VarField (mds, tp, id, Some (EBinOp (OpAssign, EId id, ex))) + parse_field_sign >>| function + | mds, tp, id, Some ex -> + VarField (mds, tp, id, Some (EBinOp (OpAssign, EId id, ex))) | mds, tp, id, None -> VarField (mds, tp, id, None) -;; let parse_class_members = let member = - choice ?failure_msg:(Some "Method error") [ parse_method_member; parse_field_member ] + choice ?failure_msg:(Some "Method error") + [ parse_method_member; parse_field_member ] in braces @@ sep_by skip_spaces member -;; let parse_class = let class_id = - skip_spaces *> string "class" *> skip_spaces *> parse_id <|> fail "Class sign error" + skip_spaces *> string "class" *> skip_spaces *> parse_id + <|> fail "Class sign error" in lift3 (fun cl_mdf cl_id cl_mbs -> Class (cl_mdf, cl_id, cl_mbs)) (skip_spaces *> parse_modifiers) - class_id - parse_class_members -;; + class_id parse_class_members -let parse_prog : program t = parse_class <* skip_spaces >>| fun prog -> Program prog +let parse_prog : program t = + parse_class <* skip_spaces >>| fun prog -> Program prog (* Main functions *) let apply_parser parser = parse_string ~consume:Consume.All parser let parse_option p str = - match apply_parser p str with - | Ok x -> Some x - | Error _ -> None -;; + match apply_parser p str with Ok x -> Some x | Error _ -> None diff --git a/CSharpStrange/lib/parser.mli b/CSharpStrange/lib/parser.mli index 730e660b..b6f5c7fe 100644 --- a/CSharpStrange/lib/parser.mli +++ b/CSharpStrange/lib/parser.mli @@ -6,6 +6,7 @@ open Ast open Angstrom open Base +val reserved : string list val parens : 'a t -> 'a t val braces : 'a t -> 'a t val brackets : 'a t -> 'a t diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 34646bd5..1e35b370 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -12,149 +12,163 @@ let%test "Parse false" = apply_parser parse_bool {|false|} = Ok (ValBool false) let%test "Parse string" = apply_parser parse_val_string {|"sample"|} = Ok (ValString "sample") -;; -let%test "Parse parens" = apply_parser (parens parse_int) {|(1)|} = Ok (ValInt 1) -let%test "Parse braces" = apply_parser (braces parse_int) {|{1}|} = Ok (ValInt 1) -let%test "Parse brackets" = apply_parser (brackets parse_int) {|[1]|} = Ok (ValInt 1) -let%test "Parse one modifier 1" = apply_parser parse_modifiers {|static|} = Ok [ MStatic ] -let%test "Parse one modifier 2" = apply_parser parse_modifiers {|public|} = Ok [ MPublic ] +let%test "Parse parens" = + apply_parser (parens parse_int) {|(1)|} = Ok (ValInt 1) + +let%test "Parse braces" = + apply_parser (braces parse_int) {|{1}|} = Ok (ValInt 1) + +let%test "Parse brackets" = + apply_parser (brackets parse_int) {|[1]|} = Ok (ValInt 1) + +let%test "Parse one modifier 1" = + apply_parser parse_modifiers {|static|} = Ok [ MStatic ] + +let%test "Parse one modifier 2" = + apply_parser parse_modifiers {|public|} = Ok [ MPublic ] let%test "Parse two modifiers" = apply_parser parse_modifiers {|public async|} = Ok [ MPublic; MAsync ] -;; let%test "Parse add 1" = apply_parser parse_ops {| 1 + 2|} = Ok (EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2))) -;; let%test "Parse add 2" = - apply_parser parse_ops {| a + b|} = Ok (EBinOp (OpAdd, EId (Id "a"), EId (Id "b"))) -;; + apply_parser parse_ops {| a + b|} + = Ok (EBinOp (OpAdd, EId (Id "a"), EId (Id "b"))) let%test "Parse many adds" = apply_parser parse_ops {| 1 + 2 + 3|} = Ok (EBinOp - (OpAdd, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) -;; + ( OpAdd, + EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), + EValue (ValInt 3) )) let%test "Parse adds with mul 1" = apply_parser parse_ops {|1 + 2 * 3|} = Ok (EBinOp - (OpAdd, EValue (ValInt 1), EBinOp (OpMul, EValue (ValInt 2), EValue (ValInt 3)))) -;; + ( OpAdd, + EValue (ValInt 1), + EBinOp (OpMul, EValue (ValInt 2), EValue (ValInt 3)) )) let%test "Parse adds with mul 2" = apply_parser parse_ops {| (1 + 2 ) * 3|} = Ok (EBinOp - (OpMul, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) -;; + ( OpMul, + EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), + EValue (ValInt 3) )) let%test "Parse div with mod" = apply_parser parse_ops {| 1 / 2 % 3|} = Ok (EBinOp - (OpMod, EBinOp (OpDiv, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) -;; + ( OpMod, + EBinOp (OpDiv, EValue (ValInt 1), EValue (ValInt 2)), + EValue (ValInt 3) )) let%test "Parse div with mod" = apply_parser parse_ops {| 1 - 2 / 3 + 4|} = Ok (EBinOp - ( OpAdd - , EBinOp - ( OpSub - , EValue (ValInt 1) - , EBinOp (OpDiv, EValue (ValInt 2), EValue (ValInt 3)) ) - , EValue (ValInt 4) )) -;; + ( OpAdd, + EBinOp + ( OpSub, + EValue (ValInt 1), + EBinOp (OpDiv, EValue (ValInt 2), EValue (ValInt 3)) ), + EValue (ValInt 4) )) let%test "Parse simple boolean expression" = apply_parser parse_ops {| ( 1 + 2 == 3 + 4 )|} = Ok (EBinOp - ( OpEqual - , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) - , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) )) -;; + ( OpEqual, + EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), + EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) )) let%test "Parse complex boolean expression" = apply_parser parse_ops {|( 1 + 2 < 3 + 4) && (5 == 8)|} = Ok (EBinOp - ( OpAnd - , EBinOp - ( OpLess - , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) - , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) ) - , EBinOp (OpEqual, EValue (ValInt 5), EValue (ValInt 8)) )) -;; + ( OpAnd, + EBinOp + ( OpLess, + EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), + EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) ), + EBinOp (OpEqual, EValue (ValInt 5), EValue (ValInt 8)) )) let%test "Parse ident expr" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) -let%test "Parse id in expressions 1" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) + +let%test "Parse id in expressions 1" = + apply_parser parse_ops {| x|} = Ok (EId (Id "x")) let%test "Parse id in expressions 2" = - apply_parser parse_ops {|x + 1|} = Ok (EBinOp (OpAdd, EId (Id "x"), EValue (ValInt 1))) -;; + apply_parser parse_ops {|x + 1|} + = Ok (EBinOp (OpAdd, EId (Id "x"), EValue (ValInt 1))) let%test "Parse var declaration 1" = apply_parser parse_decl {|int x|} = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), None)) -;; let%test "Parse var declaration 2" = apply_parser parse_decl {|int x = 1|} - = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1)))) -;; + = Ok + (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1)))) let%test "Parse multiple var declarations" = apply_parser parse_decl {|int x = y = z = 1|} = Ok (SDecl - ( Var (TypeVar (TypeBase TypeInt), Id "x") - , Some + ( Var (TypeVar (TypeBase TypeInt), Id "x"), + Some (EBinOp - ( OpAssign - , EId (Id "y") - , EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) -;; + ( OpAssign, + EId (Id "y"), + EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) let%test "Parse return 1" = - apply_parser parse_return {|return 5|} = Ok (SReturn (Some (EValue (ValInt 5)))) -;; + apply_parser parse_return {|return 5|} + = Ok (SReturn (Some (EValue (ValInt 5)))) + +let%test "Parse return 2" = + apply_parser parse_return {|return|} = Ok (SReturn None) -let%test "Parse return 2" = apply_parser parse_return {|return|} = Ok (SReturn None) let%test "Parse break" = apply_parser parse_break {|break|} = Ok SBreak -let%test "Parse continue" = apply_parser parse_continue {|continue|} = Ok SContinue -let%test "Parse empty block 1" = apply_parser parse_block {|{}|} = Ok (SBlock []) -let%test "Parse empty block 2" = apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) + +let%test "Parse continue" = + apply_parser parse_continue {|continue|} = Ok SContinue + +let%test "Parse empty block 1" = + apply_parser parse_block {|{}|} = Ok (SBlock []) + +let%test "Parse empty block 2" = + apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) let%test "Parse block 1" = apply_parser parse_block {|{return 5;}|} = Ok (SBlock [ SReturn (Some (EValue (ValInt 5))) ]) -;; let%test "Parse block 2" = apply_parser parse_block {|{int x = 6; x = 6 + 1; return x;}|} = Ok (SBlock - [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 6))) - ; SExpr + [ + SDecl + (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 6))); + SExpr (EBinOp - ( OpAssign - , EId (Id "x") - , EBinOp (OpAdd, EValue (ValInt 6), EValue (ValInt 1)) )) - ; SReturn (Some (EId (Id "x"))) + ( OpAssign, + EId (Id "x"), + EBinOp (OpAdd, EValue (ValInt 6), EValue (ValInt 1)) )); + SReturn (Some (EId (Id "x"))); ]) -;; let%test "Parse while" = - apply_parser - parse_block + apply_parser parse_block {| { int x = 1; @@ -167,20 +181,21 @@ let%test "Parse while" = }|} = Ok (SBlock - [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1))) - ; SWhile - ( EBinOp (OpLess, EId (Id "x"), EValue (ValInt 1)) - , SBlock - [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) - ; SBreak - ; SContinue - ] ) + [ + SDecl + (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1))); + SWhile + ( EBinOp (OpLess, EId (Id "x"), EValue (ValInt 1)), + SBlock + [ + SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))); + SBreak; + SContinue; + ] ); ]) -;; let%test "Parse for" = - apply_parser - parse_block + apply_parser parse_block {|{ for (int i = 1;i < 5; i = i+1) { @@ -189,29 +204,30 @@ let%test "Parse for" = }|} = Ok (SBlock - [ SFor + [ + SFor ( Some (SDecl - (Var (TypeVar (TypeBase TypeInt), Id "i"), Some (EValue (ValInt 1)))) - , Some (EBinOp (OpLess, EId (Id "i"), EValue (ValInt 5))) - , Some + ( Var (TypeVar (TypeBase TypeInt), Id "i"), + Some (EValue (ValInt 1)) )), + Some (EBinOp (OpLess, EId (Id "i"), EValue (ValInt 5))), + Some (EBinOp - ( OpAssign - , EId (Id "i") - , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) - , SBlock - [ SExpr + ( OpAssign, + EId (Id "i"), + EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )), + SBlock + [ + SExpr (EBinOp - ( OpAssign - , EId (Id "i") - , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) - ] ) + ( OpAssign, + EId (Id "i"), + EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )); + ] ); ]) -;; let%test "Parse if" = - apply_parser - parse_block + apply_parser parse_block {|{if (x == 5) x=1; else if (x == 2) @@ -221,37 +237,37 @@ let%test "Parse if" = }|} = Ok (SBlock - [ SIf - ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 5)) - , SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 1))) - , Some + [ + SIf + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 5)), + SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 1))), + Some (SIf - ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 2)) - , SBlock - [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) ] - , None )) ) + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 2)), + SBlock + [ + SExpr + (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))); + ], + None )) ); ]) -;; let%test "Parse field 1" = apply_parser parse_field_member {|public int X;|} = Ok (VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None)) -;; let%test "Parse field 2" = apply_parser parse_field_member {|public int X = 1;|} = Ok (VarField - ( [ MPublic ] - , TypeVar (TypeBase TypeInt) - , Id "X" - , Some (EBinOp (OpAssign, EId (Id "X"), EValue (ValInt 1))) )) -;; + ( [ MPublic ], + TypeVar (TypeBase TypeInt), + Id "X", + Some (EBinOp (OpAssign, EId (Id "X"), EValue (ValInt 1))) )) let%test "Parse method 1" = apply_parser parse_method_member {|public int Func() {}|} = Ok (Method ([ MPublic ], TypeBase TypeInt, Id "Func", Params [], SBlock [])) -;; let%test "Parse method 2" = apply_parser parse_method_member {|public int Func() @@ -260,16 +276,14 @@ let%test "Parse method 2" = }|} = Ok (Method - ( [ MPublic ] - , TypeBase TypeInt - , Id "Func" - , Params [] - , SBlock [ SReturn (Some (EValue (ValInt 2))) ] )) -;; + ( [ MPublic ], + TypeBase TypeInt, + Id "Func", + Params [], + SBlock [ SReturn (Some (EValue (ValInt 2))) ] )) let%test "Parse method 3" = - apply_parser - parse_method_member + apply_parser parse_method_member {|public int Factorial(int n) { if (n == 0) @@ -283,39 +297,42 @@ let%test "Parse method 3" = }|} = Ok (Method - ( [ MPublic ] - , TypeBase TypeInt - , Id "Factorial" - , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] - , SBlock - [ SIf - ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) - , SBlock [ SReturn (Some (EValue (ValInt 1))) ] - , Some + ( [ MPublic ], + TypeBase TypeInt, + Id "Factorial", + Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ], + SBlock + [ + SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)), + SBlock [ SReturn (Some (EValue (ValInt 1))) ], + Some (SBlock - [ SReturn + [ + SReturn (Some (EBinOp - ( OpMul - , EId (Id "n") - , EFuncCall - ( EId (Id "Factorial") - , Args - [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) - ] ) ))) - ]) ) + ( OpMul, + EId (Id "n"), + EFuncCall + ( EId (Id "Factorial"), + Args + [ + EBinOp + ( OpSub, + EId (Id "n"), + EValue (ValInt 1) ); + ] ) ))); + ]) ); ] )) -;; let%test "Parse class 1" = apply_parser parse_class {| public class Sample {}|} = Ok (Class ([ MPublic ], Id "Sample", [])) -;; let%test "Parse class 2" = - apply_parser - parse_class + apply_parser parse_class {| public class Sample { public int X; @@ -323,20 +340,19 @@ let%test "Parse class 2" = }|} = Ok (Class - ( [ MPublic ] - , Id "Sample" - , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) - ; VarField - ( [ MPublic ] - , TypeVar (TypeBase TypeInt) - , Id "Y" - , Some (EBinOp (OpAssign, EId (Id "Y"), EValue (ValInt 1))) ) + ( [ MPublic ], + Id "Sample", + [ + VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None); + VarField + ( [ MPublic ], + TypeVar (TypeBase TypeInt), + Id "Y", + Some (EBinOp (OpAssign, EId (Id "Y"), EValue (ValInt 1))) ); ] )) -;; let%test "Parse class 3" = - apply_parser - parse_class + apply_parser parse_class {| public class Sample { @@ -348,27 +364,27 @@ let%test "Parse class 3" = }|} = Ok (Class - ( [ MPublic ] - , Id "Sample" - , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) - ; Method - ( [ MPublic ] - , TypeBase TypeInt - , Id "add" - , Params [ Var (TypeVar (TypeBase TypeInt), Id "x") ] - , SBlock - [ SExpr + ( [ MPublic ], + Id "Sample", + [ + VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None); + Method + ( [ MPublic ], + TypeBase TypeInt, + Id "add", + Params [ Var (TypeVar (TypeBase TypeInt), Id "x") ], + SBlock + [ + SExpr (EBinOp - ( OpAssign - , EId (Id "X") - , EBinOp (OpAdd, EId (Id "X"), EId (Id "x")) )) - ] ) + ( OpAssign, + EId (Id "X"), + EBinOp (OpAdd, EId (Id "X"), EId (Id "x")) )); + ] ); ] )) -;; let%test "Parse factorial" = - apply_parser - parse_prog + apply_parser parse_prog {| public class Program { @@ -391,34 +407,60 @@ let%test "Parse factorial" = = Ok (Program (Class - ( [ MPublic ] - , Id "Program" - , [ Method ([ MPublic; MStatic ], TypeVoid, Id "Main", Params [], SBlock []) - ; Method - ( [ MPublic ] - , TypeBase TypeInt - , Id "Factorial" - , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] - , SBlock - [ SIf - ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) - , SBlock [ SReturn (Some (EValue (ValInt 1))) ] - , Some + ( [ MPublic ], + Id "Program", + [ + Method + ( [ MPublic; MStatic ], + TypeVoid, + Id "Main", + Params [], + SBlock [] ); + Method + ( [ MPublic ], + TypeBase TypeInt, + Id "Factorial", + Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ], + SBlock + [ + SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)), + SBlock [ SReturn (Some (EValue (ValInt 1))) ], + Some (SBlock - [ SReturn + [ + SReturn (Some (EBinOp - ( OpMul - , EId (Id "n") - , EFuncCall - ( EId (Id "Factorial") - , Args - [ EBinOp - ( OpSub - , EId (Id "n") - , EValue (ValInt 1) ) - ] ) ))) - ]) ) - ] ) + ( OpMul, + EId (Id "n"), + EFuncCall + ( EId (Id "Factorial"), + Args + [ + EBinOp + ( OpSub, + EId (Id "n"), + EValue (ValInt 1) ); + ] ) ))); + ]) ); + ] ); ] ))) -;; + +let%test "parse program with weird whitespace" = + let program = + {| + class Program + { + + + static int Main() + { + + return 42 ; + + } + } + |} + in + match apply_parser parse_prog program with Ok _ -> true | Error _ -> false From 3057c521d22eb2382fb64d0ae1c025d31fd8397c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 17:08:58 +0300 Subject: [PATCH 31/84] fix(REPL): REPL fix Signed-off-by: f1i3g3 --- CSharpStrange/bin/REPL.ml | 36 +++++++++++++++++----------------- CSharpStrange/tests/ast_fact.t | 7 ++++--- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml index 42fdfde6..89da7505 100644 --- a/CSharpStrange/bin/REPL.ml +++ b/CSharpStrange/bin/REPL.ml @@ -9,21 +9,22 @@ open C_sharp_strange_lib.Common open Printf open Stdio -type opts = - { mutable dump_parse_tree : bool - ; mutable file_path : string option - ; mutable eval : bool - } +type opts = { + mutable dump_parse_tree : bool; + mutable file_path : string option; + mutable eval : bool; +} let () = let opts = { dump_parse_tree = false; file_path = None; eval = false } in let _ = Arg.parse - [ "-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n" - ; ( "-filepath" - , Arg.String (fun file_path -> opts.file_path <- Some file_path) - , "Input code in file\n" ) - ; "-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n" + [ + ("-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n"); + ( "-filepath", + Arg.String (fun file_path -> opts.file_path <- Some file_path), + "Input code in file\n" ); + ("-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n"); ] (fun _ -> Stdlib.Format.eprintf "Something got wrong\n"; @@ -36,12 +37,11 @@ let () = | Some path -> String.trim @@ In_channel.read_all path in match apply_parser parse_prog path with - | Ok ast -> - if opts.dump_parse_tree then print_endline (show_prog ast); - if opts.eval - then ( - match interpret prog with - | Ok (_, rez) -> print_endline (show_vl rez) - | Error msg -> failwith (sprintf "Interpretation error: %s" msg)) + | Ok ast -> ( + if opts.dump_parse_tree then print_endline (show_program ast); + if opts.eval then + match interpret_program ast with + | Ok (Some v) -> printf "Result: %s\n" (show_value v) + | Ok None -> printf "Result: void\n" + | Error _ -> failwith (sprintf "Interpretation error: %s" "TODO")) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) -;; diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange/tests/ast_fact.t index f62ed32b..24e62cf1 100644 --- a/CSharpStrange/tests/ast_fact.t +++ b/CSharpStrange/tests/ast_fact.t @@ -10,9 +10,10 @@ [(SReturn (Some (EBinOp (OpMul, (EId (Id "n")), (EFuncCall ((EId (Id "Factorial")), - [(EBinOp (OpSub, (EId (Id "n")), - (EValue (ValInt 1)))) - ] + (Args + [(EBinOp (OpSub, (EId (Id "n")), + (EValue (ValInt 1)))) + ]) )) )))) ])) From 1116444ae55c951d562c47ea138ffaff1853b453 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 18:11:49 +0300 Subject: [PATCH 32/84] feat(typecheck): typecheck refactor Signed-off-by: f1i3g3 --- CSharpStrange/lib/typecheck.ml | 421 ++++++++++++++----------- CSharpStrange/tests/typecheck_tests.ml | 60 ++-- 2 files changed, 261 insertions(+), 220 deletions(-) diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index a9cc540b..230b15f1 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -2,210 +2,240 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +(* TODO: refactor!! *) + open Ast open Monads.TYPECHECK open Common let value_to_type = function - | ValInt _ -> TypeInt - | ValChar _ -> TypeChar - | ValBool _ -> TypeBool - | ValString _ -> TypeString - | ValNull -> TypeInt (* TODO! *) -;; - -let vartype_to_type = function - | TypeVar t -> t -;; - -let vardecl_to_type = function - | Var (t, _) -> return (vartype_to_type t) -;; + | ValInt _ -> TypeBase TypeInt + | ValChar _ -> TypeBase TypeChar + | ValBool _ -> TypeBase TypeBool + | ValString _ -> TypeBase TypeString + | ValNull -> TypeBase TypeInt (* TODO separately? *) +let string_of_ident (Id s) = s +let vartype_to_type = function TypeVar t -> t +let vardecl_to_type = function Var (t, _) -> return (vartype_to_type t) let name_to_obj_ctx n = read_local_el n let eq f e1 e2 = - match f e1 e2 with - | true -> return e1 - | false -> fail (TCError TypeMismatch) -;; + match f e1 e2 with true -> return e1 | false -> fail (TCError TypeMismatch) let eq_type t1 t2 = eq equal__type t1 t2 let eq_ident n1 n2 = eq equal_ident n1 n2 let eq_ident_return_ctx n1 n2 m f = - match equal_ident n1 n2 with - | true -> Some (f m) - | false -> None -;; + match equal_ident n1 n2 with true -> Some (f m) | false -> None + +let field_of_ast = function + | VarField (mods, typ, id, init) -> + let is_static = + List.exists (function MStatic -> true | _ -> false) mods + in + { + field_modifiers = mods; + field_type = typ; + field_name = id; + field_init = init; + is_static; + } + | Method _ -> failwith "Expected field, got method" + +let method_of_ast = function + | Ast.Method (mods, ret_type, id, pms, body) -> + let is_static = + List.exists (function MStatic -> true | _ -> false) mods + in + let is_main = equal_ident id (Id "Main") in + { + method_modifiers = mods; + method_return = ret_type; + method_name = id; + method_params = pms; + method_body = body; + is_static; + is_main; + } + | Ast.VarField _ -> failwith "Expected method, got field" let get_class_memb id memb = match memb with - | VarField (_, _, f_id, _) -> eq_ident_return_ctx f_id id memb (fun f -> Field f) - | Method (_, _, m_id, _, _) -> eq_ident_return_ctx m_id id memb (fun m -> Method m) -;; + | VarField (_, _, f_id, _) when equal_ident f_id id -> + Some (TCField (field_of_ast memb)) + | Method (_, _, m_id, _, _) when equal_ident m_id id -> + Some (TCMethod (method_of_ast memb)) + | _ -> None -let get_class_name = function - | Class (_, id, _) -> id -;; +let get_class_name = function Class (_, id, _) -> id let find_memb_from_obj obj_id id = let find_memb b id f = List.find_map (f id) b in let find_class_memb b id = find_memb b id get_class_memb in - read_global_el obj_id - >>= function + read_global_el obj_id >>= function | TCClass (Class (_, _, b)) -> find_class_memb b id |> return -;; let is_public obj_id ctx mds = - let is_m_public = function - | MPublic -> return (Some ctx) - | _ -> fail (TCError NotImplemented) - in let rec is_m_list_public = function - | [] -> - read_global_el obj_id - >>= (function - | TCClass _ -> fail (TCError AccessError)) - | x :: xs -> - is_m_public x - >>= (function - | Some ctx -> return ctx - | None -> is_m_list_public xs) - (* TODO: bad code! *) + | [] -> return (Some ctx) + | MPublic :: _ -> return (Some ctx) + | _ :: xs -> is_m_list_public xs in is_m_list_public mds -;; + <|> (read_global_el obj_id >>= fun _ -> fail (TCError AccessError)) let find_obj_memb_with_fail n_obj n_mem = - find_memb_from_obj n_obj n_mem - >>= function - | Some memb -> - (match memb with - | Field (VarField (mds, _, _, _)) -> is_public n_obj memb mds - | Method (Method (mds, _, _, _, _)) -> is_public n_obj memb mds - | _ -> fail (TCError (ImpossibleResult "Object can only have fields and methods"))) + find_memb_from_obj n_obj n_mem >>= function + | Some memb -> ( + match memb with + | TCField f -> is_public n_obj memb f.field_modifiers + | TCMethod m -> is_public n_obj memb m.method_modifiers + | _ -> + fail + (TCError + (ImpossibleResult "Object can only have fields and methods"))) | None -> fail (TCError (OtherError "Class member not found")) -;; let find_memb_type = function - | VarType (TypeVar t) - | Field (VarField (_, TypeVar t, _, _)) - | Field (Method (_, t, _, _, _)) -> return t - | _ -> fail (TCError TypeMismatch) -;; + | TCLocalVar v -> return (vartype_to_type v.var_type) + | TCField f -> return (vartype_to_type f.field_type) + | TCMethod m -> return m.method_return let typecheck_method_args (Params params) (Args args) expr_tc = let params_to_list_of_type p = - List.map - (function - | Var (t, _) -> vartype_to_type t) - p + List.map (function Var (t, _) -> vartype_to_type t) p + in + let args_to_list_of_type a = + map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in - let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with - | 0 -> - (match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + | 0 -> ( + match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) | _ -> fail (TCError (OtherError "Method invocation check error")) in - args_to_list_of_type args - >>= fun args -> + args_to_list_of_type args >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params -;; let find_expr_type e expr_tc = expr_tc e >>= fun e -> find_memb_type e let typecheck_bin_op b e1 e2 expr_tc = let compare_two_expr_type e1 e2 = - find_expr_type e1 expr_tc - >>= fun e1 -> find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 + find_expr_type e1 expr_tc >>= fun e1 -> + find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 in let compare_three_expr_type e1 e2 t = compare_two_expr_type e1 e2 >>= fun e -> eq_type e t in - let return_rez rez = return (VarType (TypeVar rez)) in + let return_rez rez = + let var_info = { var_type = TypeVar rez; initialized = true } in + return (TCLocalVar var_info) + in match b with | OpAdd | OpMul | OpSub | OpDiv | OpMod -> - compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeInt) + compare_three_expr_type e1 e2 (TypeBase TypeInt) + *> return_rez (TypeBase TypeInt) | OpLess | OpLessEqual | OpMore | OpMoreEqual -> - compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeBool) - | OpEqual | OpNonEqual -> compare_two_expr_type e1 e2 *> return_rez (TypeBase TypeBool) + compare_three_expr_type e1 e2 (TypeBase TypeInt) + *> return_rez (TypeBase TypeBool) + | OpEqual | OpNonEqual -> + compare_two_expr_type e1 e2 *> return_rez (TypeBase TypeBool) | OpAnd | OpOr -> - compare_three_expr_type e1 e2 (TypeBase TypeBool) *> return_rez (TypeBase TypeBool) + compare_three_expr_type e1 e2 (TypeBase TypeBool) + *> return_rez (TypeBase TypeBool) | OpAssign -> - find_expr_type e1 expr_tc >>= fun e -> compare_two_expr_type e1 e2 *> return_rez e -;; + find_expr_type e1 expr_tc >>= fun e -> + compare_two_expr_type e1 e2 *> return_rez e let typecheck_un_op u e expr_tc = let tc_un_op u e = - find_expr_type e expr_tc - >>= fun t -> - match u with - | OpNot -> eq_type t (TypeBase TypeBool) + find_expr_type e expr_tc >>= fun t -> + match u with OpNot -> eq_type t (TypeBase TypeBool) in - tc_un_op u e >>= fun t -> return (VarType (TypeVar t)) -;; + tc_un_op u e >>= fun t -> + let var_info = { var_type = TypeVar t; initialized = true } in + return (TCLocalVar var_info) let tc_method_args (Params params) (Args args) expr_tc = let params_to_list_of_type p = - List.map - (function - | Var (t, _) -> vartype_to_type t) - p + List.map (function Var (t, _) -> vartype_to_type t) p + in + let args_to_list_of_type a = + map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in - let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with - | 0 -> - (match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + | 0 -> ( + match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) | _ -> fail (TCError (OtherError "Method invocation check error")) in - args_to_list_of_type args - >>= fun args -> + args_to_list_of_type args >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params -;; let tc_method_invoke e args expr_tc = - expr_tc e - >>= function - | Method (Ast.Method (_, tp, _, pms, _)) -> - tc_method_args pms args expr_tc - >>= fun _ -> - (match tp with - | TypeBase _ -> return (VarType (TypeVar tp)) - | TypeVoid -> - fail (TCError (OtherError "Void methods cannot be used in expressions"))) - | Field (Ast.VarField (_, _, _, _)) -> - fail (TCError (OtherError "Cannot call a field as a method")) - | VarType _ -> fail (TCError (OtherError "Cannot call a variable as a method")) - | _ -> fail (TCError (OtherError "Method invocation check error")) -;; + expr_tc e >>= function + | TCMethod m -> ( + tc_method_args m.method_params args expr_tc >>= fun _ -> + match m.method_return with + | TypeBase t -> + let var_info = + { var_type = TypeVar (TypeBase t); initialized = true } + in + return (TCLocalVar var_info) + | TypeVoid -> + fail + (TCError (OtherError "Void methods cannot be used in expressions"))) + | TCField _ -> fail (TCError (OtherError "Cannot call a field as a method")) + | TCLocalVar _ -> + fail (TCError (OtherError "Cannot call a variable as a method")) + +let check_initialized n = + (* TODO: refactor to locals ?? *) + read_local_el n >>= function + | TCLocalVar v when v.initialized -> return () + | TCLocalVar _ -> fail (TCError (OtherError "Variable may be uninitialized")) + | TCField _ -> return () + | TCMethod _ -> return () let typecheck_expr = let rec tc_expr_ = function - | EId n -> name_to_obj_ctx n + | EId n -> + name_to_obj_ctx n + >>= (fun ctx -> check_initialized n *> return ctx) + <|> ( get_curr_class_name >>= fun class_name -> + find_memb_from_obj class_name n >>= function + | Some memb -> return memb + | None -> + fail + (TCError + (OtherError ("Variable not found: " ^ string_of_ident n))) + ) + | EValue v -> + let var_info = + { var_type = TypeVar (value_to_type v); initialized = true } + in + return (TCLocalVar var_info) | EFuncCall (e, args) -> tc_method_invoke e args tc_expr_ | EBinOp (b, e1, e2) -> typecheck_bin_op b e1 e2 tc_expr_ | EUnOp (u, e) -> typecheck_un_op u e tc_expr_ | _ -> fail (TCError NotImplemented) in tc_expr_ -;; let typecheck_expr_with_type e = typecheck_expr e >>= fun x -> find_memb_type x -let eq_type_with_expr t e = typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t + +let eq_type_with_expr t e = + typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t let save_decl n ctx = - read_local_el_opt n - >>= function + read_local_el_opt n >>= function | None -> write_local_el n ctx | Some _ -> fail (TCError (OtherError "This variable is already declared")) -;; let apply_local f = read_local >>= fun old_l -> f *> write_local old_l @@ -215,29 +245,38 @@ let rec typecheck_stmt = in let typecheck_stmt_expr expr = match expr with - | EFuncCall (e, args) -> - (* TODO FuncCall!! *) - typecheck_expr e - >>= (function - | Method (Method (_, TypeVoid, _, pms, _)) -> - typecheck_method_args pms args typecheck_expr *> return () - | _ -> fail (TCError TypeMismatch)) + | EFuncCall (e, args) -> ( + typecheck_expr e >>= function + | TCMethod { method_return = TypeVoid; method_params = pms; _ } -> + typecheck_method_args pms args typecheck_expr *> return () + | TCMethod _ -> fail (TCError TypeMismatch) + | _ -> fail (TCError TypeMismatch)) | EBinOp (OpAssign, _, _) -> typecheck_expr expr *> return () | _ -> fail (TCError TypeMismatch) in - let typecheck_decl t n = function - | Some e -> eq_type_with_expr t e *> save_decl n (VarType (TypeVar t)) *> return () - | None -> save_decl n (VarType (TypeVar t)) *> return () + let save_decl n t initialized = + read_local_el_opt n >>= function + | None -> + let var_info = { var_type = TypeVar t; initialized } in + write_local_el n (TCLocalVar var_info) + | Some _ -> fail (TCError (OtherError "This variable is already declared")) + in + let typecheck_decl t n init_expr = + match init_expr with + | Some e -> eq_type_with_expr t e *> save_decl n t true *> return () + | None -> save_decl n t false *> return () in let typecheck_return e_opt = - read_meth_type - >>= fun m_t -> - match m_t, e_opt with + read_meth_type >>= fun m_t -> + match (m_t, e_opt) with | Some TypeVoid, None -> return () | Some (TypeBase t), Some e -> - (eq_type_with_expr (TypeBase t) e - <|> fail (TCError (OtherError "Returned type does not match the function type"))) - *> return () + (eq_type_with_expr (TypeBase t) e + <|> fail + (TCError + (OtherError "Returned type does not match the function type")) + ) + *> return () | _ -> fail (TCError TypeMismatch) in let opt_unpack f = function @@ -256,10 +295,7 @@ let rec typecheck_stmt = in let typecheck_if_state cond b s_opt tc_st = let typecheck_cond = is_expr_bool cond in - let typecheck_state = function - | Some st -> tc_st st - | None -> return () - in + let typecheck_state = function Some st -> tc_st st | None -> return () in lift3 (fun _ _ _ -> ()) typecheck_cond (tc_st b) (typecheck_state s_opt) in function @@ -268,72 +304,93 @@ let rec typecheck_stmt = | SReturn e -> typecheck_return e | SWhile (e, s) -> apply_local (is_expr_bool e *> typecheck_stmt s) | SFor (init, cond, iter, b) -> - apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) - | SIf (e, b, s_opt) -> apply_local (typecheck_if_state e b s_opt typecheck_stmt) + apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) + | SIf (e, b, s_opt) -> + apply_local (typecheck_if_state e b s_opt typecheck_stmt) | SBlock st_l -> apply_local (iter typecheck_stmt st_l) | SBreak | SContinue -> fail (TCError NotImplemented) -;; -let tc_member mem = +let tc_member mem class_fields = let tc_class_field f_type = function | Some e -> eq_type_with_expr (vartype_to_type f_type) e *> return () | None -> return () in let save_params_to_l (Params params) = let f = function - | Var (t, n) -> write_local_el n (VarType t) + | Var (t, n) -> + let var_info = { var_type = t; initialized = true } in + write_local_el n (TCLocalVar var_info) in iter f params in - let tc_meth typ params body = - apply_local (write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) + let tc_meth typ params body class_fields = + apply_local + (let add_field_to_env = function + | VarField (mods, typ, id, init) -> + let field_info = + { + field_modifiers = mods; + field_type = typ; + field_name = id; + field_init = init; + is_static = false; + } + in + write_local_el id (TCField field_info) + | Method _ -> return () + in + iter add_field_to_env class_fields + *> write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) in - let tc_class_method (mds, tp, id, pms, b) = - match equal_ident id (Id "Main") with - | true -> - (match mds, pms, tp with - | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> - tc_meth tp (Params []) b *> read_main_class - >>= (function + let tc_class_method (mds, tp, id, pms, b) class_fields = + let m = method_of_ast (Method (mds, tp, id, pms, b)) in + if m.is_main then + match (mds, pms, tp) with + | [ MStatic ], Params [], TypeBase TypeInt + | [ MStatic ], Params [], TypeVoid -> ( + tc_meth tp (Params []) b class_fields *> read_main_class >>= function | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) | Some _ -> fail (TCError (OtherError "Main method already exists"))) - | _, _, _ -> - fail - (TCError - (OtherError - "Main must be a static method, have no params and return only int or \ - void"))) - | false -> tc_meth tp pms b + | _, _, _ -> + fail + (TCError + (OtherError "Main must be static, no params, return int/void")) + else tc_meth tp pms b class_fields in match mem with | VarField (_, tp, _, e_opt) -> tc_class_field tp e_opt - | Method (mds, tp, id, pms, b) -> tc_class_method (mds, tp, id, pms, b) -;; + | Method (mds, tp, id, pms, b) -> + tc_class_method (mds, tp, id, pms, b) class_fields let save_global id ctx = - read_global_el_opt id - >>= function + read_global_el_opt id >>= function | None -> write_global_el id ctx | Some _ -> fail (TCError (OtherError "This variable is already declared")) -;; let typecheck_obj cl = - let write_mems b = - let f mem = - match mem with - | VarField (_, _, id, _) -> save_decl id (Field mem) - | Method (_, _, id, _, _) -> save_decl id (Method mem) - in - iter f b - in - let tc_mems b = iter tc_member b in - let save_class cl = save_global (get_class_name cl) (TCClass cl) in match cl with - | Class (mds, id, b) -> - write_curr_class_name id - *> apply_local (write_mems b *> save_class cl *> tc_mems b) - *> return () -;; - -let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) -let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res + | Class (mds, id, fields) -> + let write_mems () = + let f mem = + match mem with + | VarField (_, _, id, _) -> + let field_info = field_of_ast mem in + save_decl id (TCField field_info) + | Method (_, _, id, _, _) -> + let method_info = method_of_ast mem in + save_decl id (TCMethod method_info) + in + iter f fields + in + let tc_member_with_fields mem = tc_member mem fields in + let tc_mems = iter tc_member_with_fields fields in + let save_class = save_global id (TCClass cl) in + write_curr_class_name id + *> apply_local (write_mems () *> save_class *> tc_mems) + *> return () + +let typecheck prog = + run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) + +let typecheck_main prog = + typecheck prog |> fun ((_, _, _, _, main), res) -> (main, res) diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml index 88a9ab91..e7e52ebd 100644 --- a/CSharpStrange/tests/typecheck_tests.ml +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -8,17 +8,16 @@ open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Common let show_wrap = function - | Some (Program x) -> - (match typecheck x with - | _, Result.Ok _ -> Format.print_string "Ok!\n" - | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) + | Some (Program x) -> ( + match typecheck x with + | _, Result.Ok _ -> Format.print_string "Ok!\n" + | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) | _ -> Format.print_string "Some error\n" -;; let print_tc p str = show_wrap (parse_option p str) let test_ast = print_tc parse_prog -let%expect_test _ = +let%expect_test "Factorial" = test_ast {| class Program { @@ -37,11 +36,8 @@ let%expect_test _ = } |}; [%expect {| Ok! |}] -;; -(* TODO: funccall! *) - -let%expect_test _ = +let%expect_test "Wrong factorial" = test_ast {| class Program { @@ -54,12 +50,10 @@ let%expect_test _ = [%expect {| (TCError (OtherError "Returned type does not match the function type")) |}] -;; - -(* TODO: funccall! *) -let%expect_test _ = - test_ast {| +let%expect_test "Already declared variable" = + test_ast + {| class Program { int a = 5; int b = 9; @@ -67,9 +61,8 @@ let%expect_test _ = } |}; [%expect {| (TCError (OtherError "This variable is already declared")) |}] -;; -let%expect_test _ = +let%expect_test "Some types" = test_ast {| class Program { @@ -87,11 +80,10 @@ let%expect_test _ = } |}; [%expect {| Ok! |}] -;; (* TODO: parser check! *) -let%expect_test _ = +let%expect_test "String + int" = test_ast {| class Program { string a = "5"; @@ -99,11 +91,10 @@ let%expect_test _ = } |}; [%expect {| (TCError TypeMismatch) |}] -;; (* TODO: string! *) -let%expect_test _ = +let%expect_test "While" = test_ast {| class Program { @@ -126,11 +117,8 @@ let%expect_test _ = } |}; [%expect {| Ok! |}] -;; - -(* TODO: ????! *) -let%expect_test _ = +let%expect_test "For" = test_ast {| class Program { @@ -151,11 +139,10 @@ let%expect_test _ = } |}; [%expect {| Ok! |}] -;; (* TODO: some stuff here! *) -let%expect_test _ = +let%expect_test "Wrong main" = test_ast {| class Program { public virtual void Main() {} @@ -166,11 +153,10 @@ let%expect_test _ = (TCError (OtherError "Main must be a static method, have no params and return only int and void")) |}] -;; (* TODO: formatting???! *) -let%expect_test _ = +let%expect_test "Already declared function" = test_ast {| class Program { @@ -180,9 +166,8 @@ let%expect_test _ = } |}; [%expect {| (TCError (OtherError "This variable is already declared")) |}] -;; -let%expect_test _ = +let%expect_test "Function type mismatch" = test_ast {| class Program { @@ -192,14 +177,13 @@ let%expect_test _ = }|}; [%expect {| (TCError TypeMismatch) |}] -;; (* TODO: check formatting??!*) (* TODO: occurs check: smth like - {| - class Program { - public void foo() { - bool a = new A(); - }; - }|} + {| + class Program { + public void foo() { + bool a = new A(); + }; + }|} *) From c5fa3dd6cc54b5b233ba2623779a604f02b2bf60 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 18:32:47 +0300 Subject: [PATCH 33/84] feat(parser): added unop Signed-off-by: f1i3g3 --- CSharpStrange/lib/ast.ml | 109 +++++++++++++++------------- CSharpStrange/lib/parser.ml | 5 +- CSharpStrange/tests/parser_tests.ml | 22 ++++++ 3 files changed, 84 insertions(+), 52 deletions(-) diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index b07fb786..03fde91c 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -4,11 +4,11 @@ (** Values types *) type val_type = - | ValInt of int (** Int value *) - | ValChar of char (** Char value *) - | ValNull (** Null *) - | ValBool of bool (** Bool value *) - | ValString of string (** string value *) + | ValInt of int (** Int value *) + | ValChar of char (** Char value *) + | ValNull (** Null *) + | ValBool of bool (** Bool value *) + | ValString of string (** string value *) [@@deriving eq, show { with_path = false }] (** Identidicator *) @@ -16,16 +16,16 @@ type ident = Id of string [@@deriving eq, show { with_path = false }] (** Basic types declarations *) type base_type = - | TypeInt (** Declaration of int *) - | TypeChar (** Declaration of char *) - | TypeBool (** Declaration of bool *) - | TypeString (** Declaration of string *) + | TypeInt (** Declaration of int *) + | TypeChar (** Declaration of char *) + | TypeBool (** Declaration of bool *) + | TypeString (** Declaration of string *) [@@deriving eq, show { with_path = false }] (** Type delcaration *) type _type = - | TypeBase of base_type (** Declaration of basic type *) - | TypeVoid (** Declaration of void *) + | TypeBase of base_type (** Declaration of basic type *) + | TypeVoid (** Declaration of void *) [@@deriving eq, show { with_path = false }] (** Variable *) @@ -33,34 +33,38 @@ type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] (** Modifiers *) type modifier = - | MPublic (** Public modifier, used for main() method only *) - | MStatic (** Static modifier, used for main() method only *) - | MAsync (** Async modifier *) + | MPublic (** Public modifier, used for main() method only *) + | MStatic (** Static modifier, used for main() method only *) + | MAsync (** Async modifier *) [@@deriving eq, show { with_path = false }] -type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] -type params = Params of var_decl list [@@deriving eq, show { with_path = false }] +type var_decl = Var of var_type * ident +[@@deriving eq, show { with_path = false }] + +type params = Params of var_decl list +[@@deriving eq, show { with_path = false }] (** Binary operations *) type bin_op = - | OpAdd (** Sum: a [+] b *) - | OpSub (** a [-] b *) - | OpMul (** a [*] b *) - | OpDiv (** a [/] b in integers *) - | OpMod (** a [%] b *) - | OpEqual (** a [==] b *) - | OpNonEqual (** a [!=] b *) - | OpLess (** a [<] b *) - | OpMore (** a [>] b *) - | OpLessEqual (** a [<=] b *) - | OpMoreEqual (** a [>=] b *) - | OpAnd (** a [&&] b *) - | OpOr (** a [||] b *) - | OpAssign (** a [=] b *) + | OpAdd (** Sum: a [+] b *) + | OpSub (** a [-] b *) + | OpMul (** a [*] b *) + | OpDiv (** a [/] b in integers *) + | OpMod (** a [%] b *) + | OpEqual (** a [==] b *) + | OpNonEqual (** a [!=] b *) + | OpLess (** a [<] b *) + | OpMore (** a [>] b *) + | OpLessEqual (** a [<=] b *) + | OpMoreEqual (** a [>=] b *) + | OpAnd (** a [&&] b *) + | OpOr (** a [||] b *) + | OpAssign (** a [=] b *) [@@deriving eq, show { with_path = false }] (** Unary operations *) -type un_op = OpNot (** [!] a *) [@@deriving eq, show { with_path = false }] +type un_op = OpNeg (** [-] a *) | OpNot (** [!] a *) +[@@deriving eq, show { with_path = false }] (** From clauses *) type from_clause = FromClause of string * ident @@ -68,13 +72,13 @@ type from_clause = FromClause of string * ident (** Language expressions *) type expr = - | EValue of val_type (** Some value *) - | EBinOp of bin_op * expr * expr (** Binary operation *) - | EUnOp of un_op * expr (** Unary operation *) - | EId of ident (** Identificator expression *) - | EArrayAccess of expr * expr (** Array access: a = arr[i] *) - | EFuncCall of expr * args (** Call of function: name(arguments) *) (* TODO: args *) - | EAwait of expr (** [Await] expression *) + | EValue of val_type (** Some value *) + | EBinOp of bin_op * expr * expr (** Binary operation *) + | EUnOp of un_op * expr (** Unary operation *) + | EId of ident (** Identificator expression *) + | EArrayAccess of expr * expr (** Array access: a = arr[i] *) + | EFuncCall of expr * args (** Call of function: name(arguments) *) + | EAwait of expr (** [Await] expression *) [@@deriving eq, show { with_path = false }] and args = Args of expr list [@@deriving show { with_path = false }] @@ -82,29 +86,32 @@ and args = Args of expr list [@@deriving show { with_path = false }] (** Language statements *) type stmt = | SFor of stmt option * expr option * expr option * stmt - (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) + (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) | SIf of expr * stmt * stmt option - (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) - | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) - | SReturn of expr option (** Return: [return] (a) *) - | SBlock of stmt list (** Block of statements: \{ a \}; could be empty: \{\} *) - | SBreak (** Cycle [break] *) - | SContinue (** Cycle [continue] *) - | SExpr of expr (** Another expression *) - | SDecl of var_decl * expr option (** Var declaration *) + (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) + | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) + | SReturn of expr option (** Return: [return] (a) *) + | SBlock of stmt list + (** Block of statements: \{ a \}; could be empty: \{\} *) + | SBreak (** Cycle [break] *) + | SContinue (** Cycle [continue] *) + | SExpr of expr (** Another expression *) + | SDecl of var_decl * expr option (** Var declaration *) [@@deriving eq, show { with_path = false }] (** C Sharp class fields *) type field = | VarField of modifier list * var_type * ident * expr option - (** Class field - always initialized *) - | Method of modifier list * _type * ident * params * stmt (** Class method *) + (** Class field - always initialized *) + | Method of modifier list * _type * ident * params * stmt (** Class method *) [@@deriving eq, show { with_path = false }] (** C Sharp class *) type c_sharp_class = - | Class of modifier list * ident * field list (** Basic class (Program) name *) + | Class of modifier list * ident * field list + (** Basic class (Program) name *) [@@deriving eq, show { with_path = false }] (** Program AST *) -type program = Program of c_sharp_class [@@deriving eq, show { with_path = false }] +type program = Program of c_sharp_class +[@@deriving eq, show { with_path = false }] diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 0223a2bb..6158a502 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -173,6 +173,7 @@ let ( ^=^ ) = parse_bin_op "=" OpAssign (* Unary operations *) let parse_un_op op typ = parse_op op typ >>| fun t a -> EUnOp (t, a) let ( ^!^ ) = parse_un_op "!" OpNot +let ( ^!-^ ) = parse_un_op "-" OpNeg let parse_ops = fix (fun expr -> @@ -180,7 +181,7 @@ let parse_ops = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in let lv2 = - many (choice [ ( ^!^ ) ]) >>= fun ops -> + many (choice [ ( ^!^ ); ( ^!-^ ) ]) >>= fun ops -> lv1 >>= fun e -> return (List.fold_right ops ~f:(fun op acc -> op acc) ~init:e) in @@ -272,8 +273,10 @@ let parse_continue = let parse_block = fix (fun block -> let sc p = p <* skip_semicolons1 in + (* операторы, которые должны заканчиваться ; *) let op_sc p = p <* skip_semicolons in + (* операторы, которые могут не заканчиваться ; *) let body_step = choice ?failure_msg:(Some "Error in some block sentence") [ diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 1e35b370..58d458a6 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -464,3 +464,25 @@ let%test "parse program with weird whitespace" = |} in match apply_parser parse_prog program with Ok _ -> true | Error _ -> false + +let%test "Parse checking fields" = + let program = + {| + class Program { + int b = 9; + int c = b * 67; + int a = (50 % 2) + b - c; + bool r = (a != b * c) || (a >= b) && (a == c +90); + string s = "ok"; + char h = 'a'; + + void M() { + a = 5; + r = s!= "kkkk" && (190%22 == 100 * -2/5) ; + } + } + |} + in + match apply_parser parse_prog program with Ok _ -> true | Error _ -> false + +(* TODO: rewrite to normal *) From 9d0c5acb80c37a9a2c2ec26ddef754595cf35f24 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 18:36:34 +0300 Subject: [PATCH 34/84] fix: unop fix for tc & interpret Signed-off-by: f1i3g3 --- CSharpStrange/lib/interpret.ml | 784 +++++++++++++++++++++------------ CSharpStrange/lib/typecheck.ml | 61 ++- 2 files changed, 546 insertions(+), 299 deletions(-) diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange/lib/interpret.ml index d6becda2..8f6fe4a5 100644 --- a/CSharpStrange/lib/interpret.ml +++ b/CSharpStrange/lib/interpret.ml @@ -4,302 +4,502 @@ open Ast open Parser -open Typecheck -open Common -open Common.Interpret -open Monads.INTERPRET - -let is_val = function - | Value (x, _) -> return x - | _ -> fail (IError (OtherError "It's not a value")) -;; - -let is_init x = - is_val x - >>= function - | Init x -> return x - | _ -> fail (IError (OtherError "Value is not initialized")) -;; - -let is_init_val x = - is_val x - >>= function - | Init (IValue x) -> return x - | _ -> fail (IError (OtherError "Value is not initialized")) -;; - -let is_code = function - | Code c -> return c - | _ -> fail (IError (OtherError "It's not a method")) -;; - -let is_int x = - is_init_val x - >>= function - | ValInt x -> return x - | _ -> fail (IError TypeMismatch) -;; - -let is_bool x = - is_init_val x - >>= function - | ValBool x -> return x - | _ -> fail (IError TypeMismatch) -;; - -let v_int x = ValInt x -let v_bool x = ValBool x -let v_bool_not x = ValBool (not x) -let v_int_minus x = ValInt (-x) -let interpret_const c = return (Value (Init (IValue c), None)) (* TODO *) -let interpret_id n = find_local_el n - -let interpret_func_call args i_expr code i_stmt = - (* TODO *) - let get_args = map i_expr args in - is_code code - >>= function - | IMethod (m, body) -> - read_local_adr - >>= fun adr -> - get_args >>= fun args -> run_method args m.m_params adr m.m_type (i_stmt body) - | IConstructor _ -> - fail (IError (OtherError "Multiple constructors are not implemented")) -;; - -let i_assign e1 e2 i_expr = - let is_val_with_idx = function - | Value (_, i) -> return i - | _ -> - fail - (IError (OtherError "The assignment operator must assign a value to the variable")) - in - i_expr e2 - >>= is_init - >>= fun v -> - match e1 with - | EId n -> - (read_local - >>= (fun (idx, l) -> - read_local_el n - >>= is_val_with_idx - >>= fun i -> write_local (idx, IdMap.add n (Value (Init v, i)) l)) - <|> (read_local_adr - >>= fun adr -> - read_memory_obj adr - >>= fun obj -> - IdMap.find_opt n obj.mems - |> function - | Some (f, _) -> - write_memory_obj adr { obj with mems = IdMap.add n (f, Init v) obj.mems } - | None -> fail (IError TypeMismatch))) - *> find_local_el n - | _ -> - fail - (IError (OtherError "The assignment operator must assign a value to the variable")) -;; - -let i_bin_op bin_op e1 e2 i_expr = - let r_val op v f = - lift2 (fun e1 e2 -> e1, e2) (i_expr e1 >>= f) (i_expr e2 >>= f) - >>= fun (c1, c2) -> return (Value (Init (IValue (v (op c1 c2))), None)) - in - let int_r_int op = r_val op v_int is_int in - let int_r_bool op = r_val op v_bool is_int in - let bool_r_bool op = r_val op v_bool is_bool in - let not_equal_val_type c1 c2 = - equal_val_type c1 c2 - |> function - | true -> false - | false -> true - in - let eq op = r_val op v_bool is_init_val in - match bin_op with - | OpAdd -> int_r_int ( + ) - | OpMul -> int_r_int ( * ) - | OpSub -> int_r_int ( - ) - | OpDiv -> int_r_int ( / ) - | OpMod -> int_r_int ( mod ) - | OpEqual -> eq equal_val_type - | OpNonEqual -> eq not_equal_val_type - | OpLess -> int_r_bool ( < ) - | OpLessEqual -> int_r_bool ( <= ) - | OpMore -> int_r_bool ( > ) - | OpMoreEqual -> int_r_bool ( >= ) - | OpAnd -> bool_r_bool ( && ) - | OpOr -> bool_r_bool ( || ) - | OpAssign -> i_assign e1 e2 i_expr -;; - -let i_un_op un_op e i_expr i_stmt = - let res f v = i_expr e >>= f >>= fun x -> interpret_const (v x) in - match un_op with - | OpNot -> res is_bool v_bool_not -;; - -let i_expr i_statement = - let check_return = function - | Some x -> return (Value (x, None)) - | None -> fail (IError (OtherError "Void cannot be used with expr")) - in - let rec i_expr_ = function - | EId n -> interpret_id n - | EBinOp (bin_op, e1, e2) -> i_bin_op bin_op e1 e2 i_expr_ - | EUnOp (un_op, e) -> i_un_op un_op e i_expr_ i_statement - | EFuncCall (e, Args args) -> - (match e with - | EId n -> - interpret_id n - >>= fun el -> interpret_func_call args i_expr_ el i_statement >>= check_return - | _ -> fail (IError (ImpossibleResult "Check during typecheck"))) - | _ -> fail (IError NotImplemented) - in - i_expr_ -;; - -let i_stmt_expr expr i_expr i_stmt = - (* TODO !!!!!!!!!!! *) - match expr with - | EFuncCall (e, Args args) -> - i_expr e - >>= fun code -> - i_method_invoke args i_expr code i_stmt - >>= (function - | None -> return () - | Some _ -> - fail (IError (OtherError "The statement can only have a method of void type"))) - | EBinOp (OpAssign, _, _) -> i_expr expr *> return () - | _ -> fail (IError TypeMismatch) -;; - -let bool_expr i_stmt e = i_expr i_stmt e >>= is_bool - -let i_if_state i_stmt e b s_opt = - bool_expr i_stmt e - >>= function - | true -> i_stmt b - | false -> - (match s_opt with - | Some b -> i_stmt b - | None -> return ()) -;; - -let rec cycle f1 f2 = - f1 - >>= function - | true -> f2 *> cycle f1 f2 - | false -> return () -;; - -let i_while_state i_stmt e s = cycle (bool_expr i_stmt e) (i_stmt s) - -let i_for_state i_stmt init cond iter b = - let get_init = - match init with - | Some init -> i_stmt init - | None -> return () - in - let get_cond = - match cond, iter with - | Some c, Some i -> i_expr i_stmt i *> bool_expr i_stmt c - | Some c, None -> bool_expr i_stmt c - | None, Some i -> i_expr i_stmt i *> return true - | None, None -> return true - in - get_init *> cycle get_cond (i_stmt b) -;; - -let local f = - let helper idx k v acc = - match v with - | Value (v, Some (Idx cur_idx)) -> - (match cur_idx <= idx with - | true -> IdMap.add k (Value (v, Some (Idx cur_idx))) acc - | false -> acc) - | Code c -> IdMap.add k (Code c) acc - | _ -> acc - in - read_local - >>= fun (Idx i, _) -> - f *> read_local - >>= fun (_, l) -> write_local (Idx i, IdMap.fold (helper i) l IdMap.empty) -;; - -let interpret_stmt = - let rec i_stmt = function - | SExpr e -> i_sexpr e (i_expr i_stmt) i_stmt - | SDecl (Var (TypeVar _, n), e) -> - get_new_idx - >>= fun new_idx -> - (match e with - | Some e -> - i_expr i_stmt e - >>= (function - | Value (v, _) -> write_new_local_el n (Value (v, Some new_idx)) - | _ -> fail (IError (ImpossibleResult "Check during typecheck"))) - | None -> write_new_local_el n (Value (NotInit, Some new_idx))) - | SReturn e -> - (match e with - | Some e -> i_expr i_stmt e >>= is_val >>= fun r -> func_return (Some r) - | None -> func_return None) - | SWhile (e, s) -> local (i_while_state i_stmt e s) - | SFor (init, cond, iter, b) -> local (i_for_state i_stmt init cond iter b) - | SIf (e, b, s_opt) -> local (i_if_state i_stmt e b s_opt) - | SBlock st_l -> local (iter i_stmt st_l) - | SBreak | SContinue -> fail (IError NotImplemented) + +(* TODO: refactor Common *) +type interpret_error = + | NotImplemented + | NoVariable of string + | AddressNotFound of int + | VarDeclared of string + | TypeMismatch + | ImpossibleResult of string + | OtherError of string +[@@deriving show { with_path = false }] + +type error = IError of interpret_error [@@deriving show { with_path = false }] + +let ( let* ) = Result.bind (* TODO: into monad *) +let return x = Ok x + +type 'a res = ('a, interpret_error) result (* TODO: name? *) +type adr = Adr of int (* TODO?? *) [@@deriving show { with_path = false }] + +module IdMap = Map.Make (struct + type t = ident + + let compare = compare +end) + +module LocMap = Map.Make (Int) (* TODO: check Common *) + +(* TODO: check if unite with Ast *) +type value = + | VInt of int + | VBool of bool + | VChar of char + | VString of string + | VNull + | VObject of adr +[@@deriving show { with_path = false }] + +and func = { params : ident list; body : stmt } + +type location = int +type env = location IdMap.t list (* scope stack *) +type func_env = (ident * func) list (* TODO: адреса ???*) +type store = { mem : value LocMap.t; next_loc : int } + +(* Class *) +type object_id = int +type field_value = value +type object_state = { obj_id : object_id; fields : (ident * field_value) list } + +type class_def = { + name : ident; + fields : (ident * _type * expr option) list; + methods : (ident * func) list; +} + +(* end class *) + +(* TODO: state *) +type runtime = { + env : env; + fenv : func_env; + store : store; + objects : object_state list; + curr_object : object_id option; + class_def : class_def option; +} + +(* Pp value *) +let rec pp_value fmt = function + | VInt i -> Format.fprintf fmt "%d" i + | VBool b -> Format.fprintf fmt "%b" b + | VChar c -> Format.fprintf fmt "'%c'" c + | VString s -> Format.fprintf fmt "\"%s\"" s + | VNull -> Format.fprintf fmt "null" + | VObject (Adr a) -> Format.fprintf fmt "object@%d" a + +type exec_result = Normal | Return of value | Break | Continue + +let empty_runtime = + { + env = [ IdMap.empty ]; + fenv = []; + store = { next_loc = 0; mem = LocMap.empty }; + objects = []; + curr_object = None; + class_def = None; + } +(* Functions *) + +let string_of_ident (Id s) = s + +let rec lookup_env id = function + | [] -> Error (NoVariable ("variable not found: " ^ string_of_ident id)) + | scope :: rest -> ( + match IdMap.find_opt id scope with + | Some l -> Ok l + | None -> lookup_env id rest) + +let rec lookup_func_opt (id : ident) = function + | [] -> None + | (id1, v) :: _ when id1 = id -> Some v + | _ :: rest -> lookup_func_opt id rest + +let lookup_store l store = + match LocMap.find_opt l store.mem with + | Some v -> Ok v + | None -> Error (AddressNotFound l) +(*location not found *) + +let update_store l v store = { store with mem = LocMap.add l v store.mem } + +(* TODO: renaming *) +let alloc v store = + let loc = store.next_loc in + let store = { mem = LocMap.add loc v store.mem; next_loc = loc + 1 } in + (loc, store) + +(* TODO: make functions local *) +let lookup_env_r (id : ident) (rt : runtime) = lookup_env id rt.env +let lookup_store_r l rt = lookup_store l rt.store +let update_store_r l v rt = { rt with store = update_store l v rt.store } +(**) + +let alloc_r v rt = + let loc, store2 = alloc v rt.store in + (loc, { rt with store = store2 }) + +let value_of_val_type = function + | ValInt i -> VInt i + | ValChar c -> VChar c + | ValBool b -> VBool b + | ValString s -> VString s + | ValNull -> VNull + +let string_of_ident = function Id s -> s +let ident_of_vardecl = function Var (_, id) -> id + +(*expected bool*) +let expect_bool = function VBool b -> Ok b | _ -> Error TypeMismatch +let expect_int = function VInt i -> Ok i | _ -> Error TypeMismatch + +let add_var (id : ident) (loc : location) (env : env) = + match env with + | scope :: rest -> Ok (IdMap.add id loc scope :: rest) + | [] -> Error (VarDeclared (string_of_ident id)) + +let push_scope env = Ok (IdMap.empty :: env) + +let pop_scope = function + | _ :: rest -> Ok rest + | [] -> Error (OtherError "cannot pop scope") + +(* Class functions *) +let var_field_of_ast = function + | VarField (mods, TypeVar typ, id, init) -> Some (id, typ, init) + | Method _ -> None + +let method_of_ast = function + | Method (mods, ret_type, id, Params params, body) -> + let params_list = List.map (fun (Var (_, id)) -> id) params in + Some (id, { params = params_list; body }) + | VarField _ -> None + +let class_of_ast (Class (mods, name, fields)) = + let fields_list = List.filter_map var_field_of_ast fields in + let methods_list = List.filter_map method_of_ast fields in + { name; fields = fields_list; methods = methods_list } + +let find_field obj_id field_id rt = + match List.find_opt (fun o -> o.obj_id = obj_id) rt.objects with + | None -> Error (OtherError "object not found") + | Some obj -> ( + match List.find_opt (fun (id, _) -> id = field_id) obj.fields with + | Some (_, v) -> Ok v + | None -> Error (OtherError "field not found")) + +let update_field obj_id field_id new_value rt = + let rec update_obj_list = function + | [] -> [] + | obj :: rest when obj.obj_id = obj_id -> + let new_fields = + List.map + (fun (id, v) -> if id = field_id then (id, new_value) else (id, v)) + obj.fields + in + { obj with fields = new_fields } :: rest + | obj :: rest -> obj :: update_obj_list rest in - i_stmt -;; + { rt with objects = update_obj_list rt.objects } + +(* evaluation *) + +(* eval_expr : env -> func_env -> store -> expr -> value * store *) +(* TODO: move binops to one new function *) +let rec eval_expr (rt : runtime) = function + | EValue v -> return (value_of_val_type v, rt) + | EId id -> ( + match lookup_env_r id rt with + | Ok loc -> + let* v = lookup_store_r loc rt in + return (v, rt) + | Error _ -> ( + match rt.curr_object with + | None -> Error (NoVariable (string_of_ident id)) + | Some obj_id -> ( + match find_field obj_id id rt with + | Ok v -> return (v, rt) + | Error e -> Error e))) + | EBinOp (OpAssign, left, right) -> ( + let* v, rt1 = eval_expr rt right in + match left with + | EId id -> ( + match lookup_env_r id rt1 with + | Ok loc -> + let rt2 = update_store_r loc v rt1 in + return (v, rt2) + | Error _ -> ( + match rt1.curr_object with + | None -> + Error (OtherError ("cannot assign to " ^ string_of_ident id)) + | Some obj_id -> + let rt2 = update_field obj_id id v rt1 in + return (v, rt2))) + | _ -> Error TypeMismatch) + | EBinOp (OpAnd, e1, e2) -> ( + let* v1, rt1 = eval_expr rt e1 in + match v1 with + | VBool false -> return (VBool false, rt1) + | VBool true -> ( + let* v2, rt2 = eval_expr rt1 e2 in + match v2 with + | VBool b -> return (VBool b, rt2) + | _ -> Error TypeMismatch) + | _ -> Error TypeMismatch) + | EBinOp (OpOr, e1, e2) -> ( + let* v1, rt1 = eval_expr rt e1 in + match v1 with + | VBool true -> return (VBool true, rt1) + | VBool false -> ( + let* v2, rt2 = eval_expr rt1 e2 in + match v2 with + | VBool b -> return (VBool b, rt2) + | _ -> Error TypeMismatch) + | _ -> Error TypeMismatch) + | EBinOp (op, e1, e2) -> + let* v1, rt1 = eval_expr rt e1 in + let* v2, rt2 = eval_expr rt1 e2 in + eval_binop op v1 v2 rt2 + | EUnOp (OpNot, e) -> ( + (* TODO separate funtion *) + let* v, rt1 = eval_expr rt e in + match v with + | VBool b -> return (VBool (not b), rt1) + | _ -> Error TypeMismatch) + | EUnOp (OpNeg, e) -> ( + let* v, rt1 = eval_expr rt e in + match v with VInt i -> return (VInt (-i), rt1) | _ -> Error TypeMismatch) + | EFuncCall (fn_expr, Args args) -> ( + match fn_expr with + | EId id -> ( + match lookup_func_opt id rt.fenv with + | None -> + Error (OtherError ("function not found: " ^ string_of_ident id)) + | Some f -> + let rec eval_args rt = function + | [] -> return ([], rt) + | e :: rest -> + let* v, rt1 = eval_expr rt e in + let* vs, rt2 = eval_args rt1 rest in + return (v :: vs, rt2) + in + let* arg_vals, rt2 = eval_args rt args in + let* v, rt3 = call_function rt2 f arg_vals in + return (v, rt3)) + | _ -> Error (OtherError "invalid function call") (* TODO *)) + | EArrayAccess _ -> Error NotImplemented + | EAwait _ -> Error NotImplemented -let get_meth_from_class cl name = - let f acc = function - | IMethod (m, b) when equal_name m.m_name name -> return (Some (m, b)) - | _ -> return acc +(* TODO: div 0 *) +(* TODO: other types binop & unop *) +and eval_binop op v1 v2 rt : (value * runtime) res = + match (op, v1, v2) with + | OpAdd, VInt a, VInt b -> return (VInt (a + b), rt) + | OpSub, VInt a, VInt b -> return (VInt (a - b), rt) + | OpMul, VInt a, VInt b -> return (VInt (a * b), rt) + | OpDiv, VInt a, VInt b when b <> 0 -> return (VInt (a / b), rt) + | OpDiv, VInt _, VInt 0 -> Error (ImpossibleResult "Div by zero") + | OpMod, VInt a, VInt b when b <> 0 -> return (VInt (a mod b), rt) + | OpMod, VInt _, VInt 0 -> Error (ImpossibleResult "Mod by zero") + | OpEqual, v1, v2 -> return (VBool (v1 = v2), rt) + | OpNonEqual, v1, v2 -> return (VBool (v1 <> v2), rt) + | OpLess, VInt a, VInt b -> return (VBool (a < b), rt) + | OpMore, VInt a, VInt b -> return (VBool (a > b), rt) + | OpLessEqual, VInt a, VInt b -> return (VBool (a <= b), rt) + | OpMoreEqual, VInt a, VInt b -> return (VBool (a >= b), rt) + | OpAnd, VBool a, VBool b -> return (VBool (a && b), rt) + | OpOr, VBool a, VBool b -> return (VBool (a || b), rt) + | _ -> Error NotImplemented + +and call_function (rt : runtime) f args = + let caller_env = rt.env in + let caller_obj = rt.curr_object in + let rec bind_params env params args rt = + match (params, args) with + | [], [] -> return ({ rt with env }, rt) + | p :: ps, v :: vs -> + let loc, rt1 = alloc_r v rt in + let* env2 = + match env with + | scope :: rest -> Ok (IdMap.add p loc scope :: rest) + | [] -> Error (OtherError "empty environment in bind_params") + in + bind_params env2 ps vs rt1 + | _ -> Error (OtherError "argument mismatch") in - fold_left f None cl.cl_body -;; - -let run_interpreter cl_with_main g_env = - let get_g_env = - let f = function - | IntrClass cl -> write_global_el cl.cl_id (IntrClass cl) - in - f g_env + let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in + let rt_with_this = { rt_func with curr_object = caller_obj } in + let* rt2, flow = exec_stmt rt_with_this f.body in + let restored_rt = { rt2 with env = caller_env; curr_object = caller_obj } in + match flow with + | Return v -> return (v, restored_rt) + | Normal -> return (VNull, restored_rt) + | Break | Continue -> Error (OtherError "break/continue outside loop") + +(* exec_stmt : env -> func_env -> store -> stmt -> env * store * exec_result *) +and exec_stmt (rt : runtime) = function + | SExpr e -> + let* _, rt1 = eval_expr rt e in + return (rt1, Normal) + | SDecl (decl, init) -> + let id = ident_of_vardecl decl in + let* value, rt1 = + match init with None -> return (VNull, rt) | Some e -> eval_expr rt e + in + let loc, rt2 = alloc_r value rt1 in + let* env3 = add_var id loc rt2.env in + let rt3 = { rt2 with env = env3 } in + return (rt3, Normal) + | SIf (cond, then_s, else_s) -> ( + let* v, rt1 = eval_expr rt cond in + match v with + | VBool true -> exec_stmt rt1 then_s + | VBool false -> ( + match else_s with + | None -> return (rt1, Normal) + | Some s -> exec_stmt rt1 s) + | _ -> Error TypeMismatch) + | SWhile (cond, body) -> + let rec loop rt = + let* v, rt1 = eval_expr rt cond in + match v with + | VBool true -> ( + let* rt2, r = exec_stmt rt1 body in + match r with + | Normal -> loop rt2 + | Continue -> loop rt2 + | Break -> return (rt2, Normal) + | Return v -> return (rt2, Return v)) + | VBool false -> return (rt1, Normal) + | _ -> Error TypeMismatch + in + loop rt + | SBlock stmts -> + let* env1 = push_scope rt.env in + let rt1 = { rt with env = env1 } in + let* rt2, flow = exec_block rt1 stmts in + let* env3 = pop_scope rt2.env in + let rt3 = { rt2 with env = env3 } in + return (rt3, flow) + | SReturn None -> return (rt, Return VNull) + | SReturn (Some e) -> + let* v, rt1 = eval_expr rt e in + return (rt1, Return v) + | SBreak -> return (rt, Break) + | SContinue -> return (rt, Continue) + | SFor (init, cond, step, body) -> + let* env0 = push_scope rt.env in + let rt0 = { rt with env = env0 } in + let* rt1 = + match init with + | None -> return rt0 + | Some s -> ( + let* rt1, r = exec_stmt rt0 s in + match r with + | Normal -> return rt1 + | _ -> Error (OtherError "invalid control flow in for init")) + in + let rec loop rt = + let* cond_val, rt1 = + match cond with + | None -> return (VBool true, rt) + | Some e -> eval_expr rt e + in + match cond_val with + | VBool false -> return (rt1, Normal) + | VBool true -> ( + let* rt2, r = exec_stmt rt1 body in + match r with + | Return v -> return (rt2, Return v) + | Break -> return (rt2, Normal) + | Continue | Normal -> + let* rt3 = + match step with + | None -> return rt2 + | Some e -> + let* _, rt = eval_expr rt2 e in + return rt + in + loop rt3) + | _ -> Error TypeMismatch + in + let* rt2, flow = loop rt1 in + let* env3 = pop_scope rt2.env in + let rt3 = { rt2 with env = env3 } in + return (rt3, flow) + +and exec_block rt = function + | [] -> return (rt, Normal) + | s :: rest -> ( + let* rt1, r = exec_stmt rt s in + match r with Normal -> exec_block rt1 rest | _ -> return (rt1, r)) + +let init_program (Class (_, name, fields)) = + let class_def = class_of_ast (Class ([], name, fields)) in + (* Creating runtime *) + let rt = { empty_runtime with class_def = Some class_def } in + (* Program initialization *) + let rec init_fields rt fields acc = + match fields with + | [] -> Ok (rt, List.rev acc) + | (id, typ, init_opt) :: rest -> + (* При инициализации поля, другие поля уже должны быть в окружении *) + let* value, rt1 = + match init_opt with + | Some init_expr -> + (* Здесь init_expr может ссылаться на другие поля *) + eval_expr rt init_expr + | None -> + let default = + match typ with + | TypeBase TypeInt -> VInt 0 + | TypeBase TypeBool -> VBool false + | TypeBase TypeChar -> VChar '\x00' + | TypeBase TypeString -> VString "" + | TypeVoid -> VNull + in + return (default, rt) + in + init_fields rt1 rest ((id, value) :: acc) in - let get_l_env = - let save_constr cl = - write_new_local_el - cl.cl_name - (Code - (IConstructor - ( { c_modifier = [ MPublic ]; c_id = cl.cl_id; c_params = Params [] } - , SBlock [] ))) - <|> return () - in - let f = - match cl with - | Class _ -> save_constr cl - in - f g_env + let* rt1, fields_list = init_fields rt class_def.fields [] in + (* Creating Program *) + let obj_id = 0 in + let program_object = { obj_id; fields = fields_list } in + let rt2 = + { rt1 with objects = [ program_object ]; curr_object = Some obj_id } in - get_g_env *> get_l_env *> read_global_el cl_with_main - >>= function - | _ -> fail (IError NotImplemented) -;; + Ok (None, rt2) + +let interpret_program prog = + match prog with + | Program cls -> ( + match init_program cls with + | Ok (_, rt) -> ( + (* Find main *) + match rt.class_def with + | Some class_def -> ( + match + List.find_opt (fun (id, _) -> id = Id "Main") class_def.methods + with + | Some (_, main_func) -> + let* v, _ = call_function rt main_func [] in + Ok (Some v) + | None -> Error (OtherError "Main method not found")) + | None -> Error (OtherError "No class definition")) + | Error e -> Error e) let interpret str = - match apply_parser parse_prog str with - | Result.Ok (Program pr) -> - (match typecheck_main pr with - | Some cl_with_main, Result.Ok _ -> - run (run_interpreter cl_with_main pr) - |> (function - | _, Signal (Pipe x) -> Result.Ok x - | _, IError er -> Result.Error er - | _, _ -> - Result.Error (IError (ImpossibleResult "Run_method returns return or error"))) - | None, Result.Ok _ -> Result.Error (IError (OtherError "Main method not found")) - | _, Result.Error er -> Result.Error er) - | Result.Error e -> Result.Error (TCError (OtherError e)) -;; -(* TODO: not finished, should add more combinators *) + match apply_parser Parser.parse_prog str with + | Ok prog -> interpret_program prog + | Error e -> Error (OtherError e) + +(* TODO: объединить повторы в функции + unwrap_return +*) + +(* TODO: errors texts *) + +(* + TODO: класс Program с методами и полями, а также модификаторами + лямбды + что-нибудь с замыканиями + пре и пост ин/декременты + массивы (одномерные) + new + LINQ (простенький в массивы) + async/await (хотя бы без лямбд) + + ФИКС БАГОВ (Тч, парсер (Qt), интерпретатор) +*) diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 230b15f1..6575fb06 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -153,7 +153,9 @@ let typecheck_bin_op b e1 e2 expr_tc = let typecheck_un_op u e expr_tc = let tc_un_op u e = find_expr_type e expr_tc >>= fun t -> - match u with OpNot -> eq_type t (TypeBase TypeBool) + match u with + | OpNot -> eq_type t (TypeBase TypeBool) + | OpNeg -> eq_type t (TypeBase TypeInt) in tc_un_op u e >>= fun t -> let var_info = { var_type = TypeVar t; initialized = true } in @@ -203,13 +205,45 @@ let check_initialized n = | TCMethod _ -> return () let typecheck_expr = + let ( let* ) = ( >>= ) in let rec tc_expr_ = function | EId n -> + (* Отладка: что ищем *) + let* () = + Printf.printf "Looking for identifier: %s\n" (string_of_ident n); + return () + in name_to_obj_ctx n - >>= (fun ctx -> check_initialized n *> return ctx) + >>= (fun ctx -> + (* Отладка: нашли в локальных *) + let* () = + Printf.printf "Found in local env: %s\n" (string_of_ident n); + return () + in + check_initialized n *> return ctx) <|> ( get_curr_class_name >>= fun class_name -> + (* Отладка: ищем в классе *) + let* () = + Printf.printf "Looking in class: %s\n" + (string_of_ident class_name); + return () + in find_memb_from_obj class_name n >>= function - | Some memb -> return memb + | Some memb -> + (* Отладка: нашли в классе *) + let* () = + match memb with + | TCField f -> + Printf.printf "Found field in class: %s\n" + (string_of_ident f.field_name); + return () + | TCMethod m -> + Printf.printf "Found method in class: %s\n" + (string_of_ident m.method_name); + return () + | _ -> return () + in + return memb | None -> fail (TCError @@ -324,23 +358,36 @@ let tc_member mem class_fields = iter f params in let tc_meth typ params body class_fields = + Printf.printf "=== Entering tc_meth ===\n"; + Printf.printf "Method return type: %s\n" (show__type typ); + Printf.printf "Number of class fields: %d\n" (List.length class_fields); + apply_local (let add_field_to_env = function - | VarField (mods, typ, id, init) -> + | VarField (mods, field_typ, id, init) -> + Printf.printf "Adding field to env: %s\n" (string_of_ident id); let field_info = { field_modifiers = mods; - field_type = typ; + field_type = field_typ; field_name = id; field_init = init; is_static = false; } in write_local_el id (TCField field_info) - | Method _ -> return () + | Method _ -> + Printf.printf "Skipping method in fields\n"; + return () in + Printf.printf "Iterating over class fields...\n"; iter add_field_to_env class_fields - *> write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) + *> (Printf.printf "Fields added, checking params...\n"; + return ()) + *> write_meth_type typ + *> (Printf.printf "Params saved, checking body...\n"; + return ()) + *> save_params_to_l params *> typecheck_stmt body) in let tc_class_method (mds, tp, id, pms, b) class_fields = let m = method_of_ast (Method (mds, tp, id, pms, b)) in From 1ce90632216ece6ade2f7ca79c15470b00d5b0ba Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 18:53:29 +0300 Subject: [PATCH 35/84] fix(tests): fixed typecheck tests Signed-off-by: f1i3g3 --- CSharpStrange/tests/typecheck_tests.ml | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml index e7e52ebd..9d28c1ce 100644 --- a/CSharpStrange/tests/typecheck_tests.ml +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -12,7 +12,7 @@ let show_wrap = function match typecheck x with | _, Result.Ok _ -> Format.print_string "Ok!\n" | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) - | _ -> Format.print_string "Some error\n" + | _ -> Format.print_string "Parsing error\n" let print_tc p str = show_wrap (parse_option p str) let test_ast = print_tc parse_prog @@ -62,7 +62,7 @@ let%expect_test "Already declared variable" = [%expect {| (TCError (OtherError "This variable is already declared")) |}] -let%expect_test "Some types" = +let%expect_test "Checking fields" = test_ast {| class Program { @@ -99,7 +99,7 @@ let%expect_test "While" = {| class Program { static int Main() { - int counter = 0; + int count = 0; bool b = true; while(true) { if (count != 2) { @@ -145,16 +145,13 @@ let%expect_test "For" = let%expect_test "Wrong main" = test_ast {| class Program { - public virtual void Main() {} + public async void Main() {} } |}; [%expect {| (TCError - (OtherError - "Main must be a static method, have no params and return only int and void")) |}] - -(* TODO: formatting???! *) + (OtherError "Main must be static, non-async, no params, return int/void")) |}] let%expect_test "Already declared function" = test_ast @@ -173,11 +170,10 @@ let%expect_test "Function type mismatch" = class Program { public void a(int n, int m){ return n+m; - }; + } }|}; [%expect {| (TCError TypeMismatch) |}] -(* TODO: check formatting??!*) (* TODO: occurs check: smth like {| From 44eace4682be299fda4920d366ade6a704536bbe Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 19:00:34 +0300 Subject: [PATCH 36/84] fix(typecheck): removed debug Signed-off-by: f1i3g3 --- CSharpStrange/lib/typecheck.ml | 56 ++++------------------------------ 1 file changed, 6 insertions(+), 50 deletions(-) diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 6575fb06..3c5bb370 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -205,45 +205,13 @@ let check_initialized n = | TCMethod _ -> return () let typecheck_expr = - let ( let* ) = ( >>= ) in let rec tc_expr_ = function | EId n -> - (* Отладка: что ищем *) - let* () = - Printf.printf "Looking for identifier: %s\n" (string_of_ident n); - return () - in name_to_obj_ctx n - >>= (fun ctx -> - (* Отладка: нашли в локальных *) - let* () = - Printf.printf "Found in local env: %s\n" (string_of_ident n); - return () - in - check_initialized n *> return ctx) + >>= (fun ctx -> check_initialized n *> return ctx) <|> ( get_curr_class_name >>= fun class_name -> - (* Отладка: ищем в классе *) - let* () = - Printf.printf "Looking in class: %s\n" - (string_of_ident class_name); - return () - in find_memb_from_obj class_name n >>= function - | Some memb -> - (* Отладка: нашли в классе *) - let* () = - match memb with - | TCField f -> - Printf.printf "Found field in class: %s\n" - (string_of_ident f.field_name); - return () - | TCMethod m -> - Printf.printf "Found method in class: %s\n" - (string_of_ident m.method_name); - return () - | _ -> return () - in - return memb + | Some memb -> return memb | None -> fail (TCError @@ -358,14 +326,9 @@ let tc_member mem class_fields = iter f params in let tc_meth typ params body class_fields = - Printf.printf "=== Entering tc_meth ===\n"; - Printf.printf "Method return type: %s\n" (show__type typ); - Printf.printf "Number of class fields: %d\n" (List.length class_fields); - apply_local (let add_field_to_env = function | VarField (mods, field_typ, id, init) -> - Printf.printf "Adding field to env: %s\n" (string_of_ident id); let field_info = { field_modifiers = mods; @@ -376,18 +339,10 @@ let tc_member mem class_fields = } in write_local_el id (TCField field_info) - | Method _ -> - Printf.printf "Skipping method in fields\n"; - return () + | Method _ -> return () in - Printf.printf "Iterating over class fields...\n"; iter add_field_to_env class_fields - *> (Printf.printf "Fields added, checking params...\n"; - return ()) - *> write_meth_type typ - *> (Printf.printf "Params saved, checking body...\n"; - return ()) - *> save_params_to_l params *> typecheck_stmt body) + *> write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) in let tc_class_method (mds, tp, id, pms, b) class_fields = let m = method_of_ast (Method (mds, tp, id, pms, b)) in @@ -401,7 +356,8 @@ let tc_member mem class_fields = | _, _, _ -> fail (TCError - (OtherError "Main must be static, no params, return int/void")) + (OtherError + "Main must be static, non-async, no params, return int/void")) else tc_meth tp pms b class_fields in match mem with From ac7e55249548555182bb6858e84a5c92fd45c619 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 20:09:45 +0300 Subject: [PATCH 37/84] feat(interpret): major interpreter refactor + updated tests Signed-off-by: f1i3g3 --- CSharpStrange/lib/common.ml | 102 +++----- CSharpStrange/lib/common.mli | 150 ++++++------ CSharpStrange/lib/interpret.ml | 274 ++++++++++++++-------- CSharpStrange/lib/interpret.mli | 36 +++ CSharpStrange/lib/monads.ml | 312 ++++--------------------- CSharpStrange/lib/typecheck.ml | 2 - CSharpStrange/tests/dune | 2 +- CSharpStrange/tests/interpret_tests.ml | 83 +++---- 8 files changed, 395 insertions(+), 566 deletions(-) create mode 100644 CSharpStrange/lib/interpret.mli diff --git a/CSharpStrange/lib/common.ml b/CSharpStrange/lib/common.ml index 10775380..4e8f707a 100644 --- a/CSharpStrange/lib/common.ml +++ b/CSharpStrange/lib/common.ml @@ -23,9 +23,7 @@ type interpret_error = | OtherError of string [@@deriving show { with_path = false }] -type error = - | TCError of tc_error - | IError of interpret_error +type error = TCError of tc_error | IError of interpret_error [@@deriving show { with_path = false }] module Id = struct @@ -46,11 +44,33 @@ end module AdrMap = Map.Make (Adr) +type var_info = { var_type : var_type; initialized : bool (* TODO: ?? *) } +[@@deriving show { with_path = false }, eq] + +type field_info = { + field_modifiers : modifier list; + field_type : var_type; + field_name : ident; + field_init : expr option; + is_static : bool; +} +[@@deriving show { with_path = false }, eq] + +type method_info = { + method_modifiers : modifier list; + method_return : _type; + method_name : ident; + method_params : params; + method_body : stmt; + is_static : bool; + is_main : bool; +} +[@@deriving show { with_path = false }, eq] + type obj_content = - (* TODO *) - | VarType of var_type - | Method of field - | Field of field + | TCLocalVar of var_info + | TCField of field_info + | TCMethod of method_info [@@deriving show { with_path = false }, eq] type context = TCClass of c_sharp_class @@ -62,67 +82,9 @@ module TypeCheck = struct type class_with_main = ident type state = - global_env * local_env * curr_class option * _type option * class_with_main option -end - -module Interpret = struct - type idx = Idx of int [@@deriving show { with_path = false }] - - (* TODO: proper records! *) - type meth = - { m_modifiers : modifier list - ; m_type : _type - ; m_id : ident - ; m_params : params - } - [@@deriving show { with_path = false }, eq] - - type constr = - { c_modifier : modifier list - ; c_id : ident - ; c_params : params - } - [@@deriving show { with_path = false }, eq] - - type code = - | IConstructor of constr * stmt - | IMethod of meth * stmt - [@@deriving show { with_path = false }, eq] - (* TODO: proper records! *) - - type class_ = - { cl_modifiers : modifier list - ; cl_id : ident - ; cl_body : code list - } - [@@deriving show { with_path = false }, eq] - - type el = - | IClass of adr - | IValue of val_type - [@@deriving show { with_path = false }] - - type vl = - | Init of el - | NotInit - [@@deriving show { with_path = false }] - - type local_el = - | Code of code - | Value of vl * idx option - - type local_env = idx (* new idx *) * local_el IdMap.t - - type obj = - { mems : (field * vl) IdMap.t - ; cl_name : ident - ; p_adr : adr option - ; inh_adr : adr option - } - - type context = IntrClass of class_ [@@deriving show { with_path = false }] - type memory = adr * obj AdrMap.t - type local_adr = adr - type global_env = context IdMap.t - type state = global_env * local_env * local_adr * memory + global_env + * local_env + * curr_class option + * _type option + * class_with_main option end diff --git a/CSharpStrange/lib/common.mli b/CSharpStrange/lib/common.mli index 69c22a39..f021b1dc 100644 --- a/CSharpStrange/lib/common.mli +++ b/CSharpStrange/lib/common.mli @@ -4,7 +4,8 @@ open Ast -type tc_error = +(** Type checker error types *) +type tc_error = | NotImplemented | OccursCheck | AccessError @@ -15,6 +16,7 @@ type tc_error = val pp_tc_error : Format.formatter -> tc_error -> unit val show_tc_error : tc_error -> string +(** Interpreter error types *) type interpret_error = | NotImplemented | NoVariable of string @@ -27,124 +29,104 @@ type interpret_error = val pp_interpret_error : Format.formatter -> interpret_error -> unit val show_interpret_error : interpret_error -> string -type error = - | TCError of tc_error - | IError of interpret_error +(** Combined error type *) +type error = TCError of tc_error | IError of interpret_error val pp_error : Format.formatter -> error -> unit val show_error : error -> string - +(** Identifier module *) module Id : sig type t = ident - val compare : 't -> 't -> int + + val compare : t -> t -> int end +(** Map from identifiers *) module IdMap : sig - include Map.S with type key = Ast.ident + include Map.S with type key = ident end -type adr = Adr of int +(** Address type *) +type adr = Adr of int val pp_adr : Format.formatter -> adr -> unit val show_adr : adr -> string +(** Address module *) module Adr : sig type t = adr - val compare : 't -> 't -> int + + val compare : t -> t -> int end +(** Map from addresses *) module AdrMap : sig include Map.S with type key = adr end +type var_info = { + var_type : var_type; + initialized : bool; (** Whether the variable has been initialized *) +} +(** Variable information for type checker *) + +val pp_var_info : Format.formatter -> var_info -> unit +val show_var_info : var_info -> string +val equal_var_info : var_info -> var_info -> bool + +type field_info = { + field_modifiers : modifier list; + field_type : var_type; + field_name : ident; + field_init : expr option; + is_static : bool; +} +(** Field information for type checker *) + +val pp_field_info : Format.formatter -> field_info -> unit +val show_field_info : field_info -> string +val equal_field_info : field_info -> field_info -> bool + +type method_info = { + method_modifiers : modifier list; + method_return : _type; + method_name : ident; + method_params : params; + method_body : stmt; + is_static : bool; + is_main : bool; (** Whether this is the Main method *) +} +(** Method information for type checker *) + +val pp_method_info : Format.formatter -> method_info -> unit +val show_method_info : method_info -> string +val equal_method_info : method_info -> method_info -> bool + +(** Type checker content types *) type obj_content = - | VarType of Ast.var_type - | Method of Ast.field - | Field of Ast.field + | TCLocalVar of var_info (** Local variable *) + | TCField of field_info (** Class field *) + | TCMethod of method_info (** Class method *) val pp_obj_content : Format.formatter -> obj_content -> unit val show_obj_content : obj_content -> string val equal_obj_content : obj_content -> obj_content -> bool +(** Global context for type checker *) type context = TCClass of c_sharp_class +(** Type checker state module *) module TypeCheck : sig type global_env = context IdMap.t type local_env = obj_content IdMap.t type curr_class = ident type class_with_main = ident - - type state = - global_env * local_env * curr_class option * _type option * class_with_main option -end - -module Interpret : sig - type idx = Idx of int - - val pp_idx : Format.formatter -> idx -> unit - val show_idx : idx -> string - - type meth = { - m_modifiers : modifier list; - m_type : _type; - m_id : ident; - m_params : params; - } - - type constr = { - c_modifier : modifier list; - c_id : ident; - c_params : params; - } - - type code = - | IConstructor of constr * stmt - | IMethod of meth * stmt - - val pp_code : Format.formatter -> code -> unit - val show_code : code -> string - - type class_ = { - cl_modifiers : modifier list; - cl_id : ident; - cl_body : code list; - } - type el = - | IClass of adr - | IValue of val_type - - val pp_el : Format.formatter -> el -> unit - val show_el : el -> string - - type vl = - | Init of el - | NotInit - - val pp_vl : Format.formatter -> vl -> unit - val show_vl : vl -> string - - type local_el = - | Code of code - | Value of vl * idx option - - type local_env = idx * local_el IdMap.t - - type obj = { - mems : (field * vl) IdMap.t; - cl_name : ident; - p_adr : adr option; - inh_adr : adr option; - } - - type context = IntrClass of class_ - - val pp_context : Format.formatter -> context -> unit - val show_context : context -> string - - type memory = adr * obj AdrMap.t - type local_adr = adr - type global_env = context IdMap.t - type state = global_env * local_env * local_adr * memory + type state = + global_env + * local_env + * curr_class option + * _type option + * class_with_main option end diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange/lib/interpret.ml index 8f6fe4a5..0de64012 100644 --- a/CSharpStrange/lib/interpret.ml +++ b/CSharpStrange/lib/interpret.ml @@ -5,7 +5,6 @@ open Ast open Parser -(* TODO: refactor Common *) type interpret_error = | NotImplemented | NoVariable of string @@ -18,11 +17,11 @@ type interpret_error = type error = IError of interpret_error [@@deriving show { with_path = false }] -let ( let* ) = Result.bind (* TODO: into monad *) +let ( let* ) = Result.bind let return x = Ok x -type 'a res = ('a, interpret_error) result (* TODO: name? *) -type adr = Adr of int (* TODO?? *) [@@deriving show { with_path = false }] +type 'a res = ('a, interpret_error) result +type adr = Adr of int [@@deriving show { with_path = false }] module IdMap = Map.Make (struct type t = ident @@ -30,9 +29,8 @@ module IdMap = Map.Make (struct let compare = compare end) -module LocMap = Map.Make (Int) (* TODO: check Common *) +module LocMap = Map.Make (Int) -(* TODO: check if unite with Ast *) type value = | VInt of int | VBool of bool @@ -45,24 +43,20 @@ type value = and func = { params : ident list; body : stmt } type location = int -type env = location IdMap.t list (* scope stack *) -type func_env = (ident * func) list (* TODO: адреса ???*) +type var_info = { loc : location; initialized : bool } +type env = var_info IdMap.t list +type func_env = (ident * func) list type store = { mem : value LocMap.t; next_loc : int } - -(* Class *) type object_id = int type field_value = value type object_state = { obj_id : object_id; fields : (ident * field_value) list } type class_def = { name : ident; - fields : (ident * _type * expr option) list; + fields : (ident * _type * expr option * bool) list; methods : (ident * func) list; } -(* end class *) - -(* TODO: state *) type runtime = { env : env; fenv : func_env; @@ -70,9 +64,9 @@ type runtime = { objects : object_state list; curr_object : object_id option; class_def : class_def option; + static_fields : (ident * value) list; } -(* Pp value *) let rec pp_value fmt = function | VInt i -> Format.fprintf fmt "%d" i | VBool b -> Format.fprintf fmt "%b" b @@ -91,8 +85,8 @@ let empty_runtime = objects = []; curr_object = None; class_def = None; + static_fields = []; } -(* Functions *) let string_of_ident (Id s) = s @@ -100,9 +94,33 @@ let rec lookup_env id = function | [] -> Error (NoVariable ("variable not found: " ^ string_of_ident id)) | scope :: rest -> ( match IdMap.find_opt id scope with - | Some l -> Ok l + | Some var_info -> Ok var_info.loc | None -> lookup_env id rest) +let check_initialized id env = + let rec find_var = function + | [] -> Error (NoVariable (string_of_ident id)) + | scope :: rest -> ( + match IdMap.find_opt id scope with + | Some var_info -> + if var_info.initialized then Ok () + else Error (OtherError "Value is not initialized") + | None -> find_var rest) + in + find_var env + +let mark_initialized id env = + let rec mark_in_scope = function + | [] -> [] + | scope :: rest -> ( + match IdMap.find_opt id scope with + | Some var_info -> + let new_var_info = { var_info with initialized = true } in + IdMap.add id new_var_info scope :: rest + | None -> scope :: mark_in_scope rest) + in + mark_in_scope env + let rec lookup_func_opt (id : ident) = function | [] -> None | (id1, v) :: _ when id1 = id -> Some v @@ -112,21 +130,17 @@ let lookup_store l store = match LocMap.find_opt l store.mem with | Some v -> Ok v | None -> Error (AddressNotFound l) -(*location not found *) let update_store l v store = { store with mem = LocMap.add l v store.mem } -(* TODO: renaming *) let alloc v store = let loc = store.next_loc in let store = { mem = LocMap.add loc v store.mem; next_loc = loc + 1 } in (loc, store) -(* TODO: make functions local *) let lookup_env_r (id : ident) (rt : runtime) = lookup_env id rt.env let lookup_store_r l rt = lookup_store l rt.store let update_store_r l v rt = { rt with store = update_store l v rt.store } -(**) let alloc_r v rt = let loc, store2 = alloc v rt.store in @@ -141,14 +155,14 @@ let value_of_val_type = function let string_of_ident = function Id s -> s let ident_of_vardecl = function Var (_, id) -> id - -(*expected bool*) let expect_bool = function VBool b -> Ok b | _ -> Error TypeMismatch let expect_int = function VInt i -> Ok i | _ -> Error TypeMismatch let add_var (id : ident) (loc : location) (env : env) = match env with - | scope :: rest -> Ok (IdMap.add id loc scope :: rest) + | scope :: rest -> + let var_info = { loc; initialized = false } in + Ok (IdMap.add id var_info scope :: rest) | [] -> Error (VarDeclared (string_of_ident id)) let push_scope env = Ok (IdMap.empty :: env) @@ -157,9 +171,13 @@ let pop_scope = function | _ :: rest -> Ok rest | [] -> Error (OtherError "cannot pop scope") -(* Class functions *) let var_field_of_ast = function - | VarField (mods, TypeVar typ, id, init) -> Some (id, typ, init) + | VarField (mods, TypeVar typ, id, init) -> + Some + ( id, + typ, + init, + List.exists (function MStatic -> true | _ -> false) mods ) | Method _ -> None let method_of_ast = function @@ -195,39 +213,62 @@ let update_field obj_id field_id new_value rt = in { rt with objects = update_obj_list rt.objects } -(* evaluation *) +let find_static_field field_id rt = + match List.find_opt (fun (id, _) -> id = field_id) rt.static_fields with + | Some (_, v) -> Ok v + | None -> Error (NoVariable (string_of_ident field_id)) + +let update_static_field field_id new_value rt = + let rec update_static_list = function + | [] -> [ (field_id, new_value) ] + | (id, v) :: rest when id = field_id -> (id, new_value) :: rest + | (id, v) :: rest -> (id, v) :: update_static_list rest + in + { rt with static_fields = update_static_list rt.static_fields } -(* eval_expr : env -> func_env -> store -> expr -> value * store *) -(* TODO: move binops to one new function *) let rec eval_expr (rt : runtime) = function | EValue v -> return (value_of_val_type v, rt) | EId id -> ( - match lookup_env_r id rt with - | Ok loc -> - let* v = lookup_store_r loc rt in - return (v, rt) + match lookup_env id rt.env with + | Ok loc -> ( + match check_initialized id rt.env with + | Ok () -> + let* v = lookup_store_r loc rt in + return (v, rt) + | Error e -> Error e) | Error _ -> ( - match rt.curr_object with - | None -> Error (NoVariable (string_of_ident id)) - | Some obj_id -> ( - match find_field obj_id id rt with - | Ok v -> return (v, rt) - | Error e -> Error e))) + match find_static_field id rt with + | Ok v -> return (v, rt) + | Error _ -> ( + match rt.curr_object with + | None -> Error (NoVariable (string_of_ident id)) + | Some obj_id -> ( + match find_field obj_id id rt with + | Ok v -> return (v, rt) + | Error e -> Error e)))) | EBinOp (OpAssign, left, right) -> ( let* v, rt1 = eval_expr rt right in match left with | EId id -> ( - match lookup_env_r id rt1 with + match lookup_env id rt1.env with | Ok loc -> - let rt2 = update_store_r loc v rt1 in - return (v, rt2) + let new_env = mark_initialized id rt1.env in + let rt2 = { rt1 with env = new_env } in + let rt3 = update_store_r loc v rt2 in + return (v, rt3) | Error _ -> ( - match rt1.curr_object with - | None -> - Error (OtherError ("cannot assign to " ^ string_of_ident id)) - | Some obj_id -> - let rt2 = update_field obj_id id v rt1 in - return (v, rt2))) + match find_static_field id rt1 with + | Ok _ -> + let rt2 = update_static_field id v rt1 in + return (v, rt2) + | Error _ -> ( + match rt1.curr_object with + | None -> + Error + (OtherError ("cannot assign to " ^ string_of_ident id)) + | Some obj_id -> + let rt2 = update_field obj_id id v rt1 in + return (v, rt2)))) | _ -> Error TypeMismatch) | EBinOp (OpAnd, e1, e2) -> ( let* v1, rt1 = eval_expr rt e1 in @@ -254,7 +295,6 @@ let rec eval_expr (rt : runtime) = function let* v2, rt2 = eval_expr rt1 e2 in eval_binop op v1 v2 rt2 | EUnOp (OpNot, e) -> ( - (* TODO separate funtion *) let* v, rt1 = eval_expr rt e in match v with | VBool b -> return (VBool (not b), rt1) @@ -279,12 +319,10 @@ let rec eval_expr (rt : runtime) = function let* arg_vals, rt2 = eval_args rt args in let* v, rt3 = call_function rt2 f arg_vals in return (v, rt3)) - | _ -> Error (OtherError "invalid function call") (* TODO *)) + | _ -> Error (OtherError "invalid function call")) | EArrayAccess _ -> Error NotImplemented | EAwait _ -> Error NotImplemented -(* TODO: div 0 *) -(* TODO: other types binop & unop *) and eval_binop op v1 v2 rt : (value * runtime) res = match (op, v1, v2) with | OpAdd, VInt a, VInt b -> return (VInt (a + b), rt) @@ -312,9 +350,10 @@ and call_function (rt : runtime) f args = | [], [] -> return ({ rt with env }, rt) | p :: ps, v :: vs -> let loc, rt1 = alloc_r v rt in + let var_info = { loc; initialized = true } in let* env2 = match env with - | scope :: rest -> Ok (IdMap.add p loc scope :: rest) + | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) | [] -> Error (OtherError "empty environment in bind_params") in bind_params env2 ps vs rt1 @@ -329,7 +368,6 @@ and call_function (rt : runtime) f args = | Normal -> return (VNull, restored_rt) | Break | Continue -> Error (OtherError "break/continue outside loop") -(* exec_stmt : env -> func_env -> store -> stmt -> env * store * exec_result *) and exec_stmt (rt : runtime) = function | SExpr e -> let* _, rt1 = eval_expr rt e in @@ -341,7 +379,10 @@ and exec_stmt (rt : runtime) = function in let loc, rt2 = alloc_r value rt1 in let* env3 = add_var id loc rt2.env in - let rt3 = { rt2 with env = env3 } in + let env4 = + match init with Some _ -> mark_initialized id env3 | None -> env3 + in + let rt3 = { rt2 with env = env4 } in return (rt3, Normal) | SIf (cond, then_s, else_s) -> ( let* v, rt1 = eval_expr rt cond in @@ -427,49 +468,90 @@ and exec_block rt = function let* rt1, r = exec_stmt rt s in match r with Normal -> exec_block rt1 rest | _ -> return (rt1, r)) +let rec init_static_fields rt fields acc = + match fields with + | [] -> Ok (rt, List.rev acc) + | (id, typ, init_opt) :: rest -> + let default_value = + match typ with + | TypeBase TypeInt -> VInt 0 + | TypeBase TypeBool -> VBool false + | TypeBase TypeChar -> VChar '\x00' + | TypeBase TypeString -> VString "" + | TypeVoid -> VNull + in + let rt_with_field = + { rt with static_fields = (id, default_value) :: rt.static_fields } + in + let* value, rt1 = + match init_opt with + | Some init_expr -> eval_expr rt_with_field init_expr + | None -> return (default_value, rt_with_field) + in + let rt2 = update_static_field id value rt1 in + init_static_fields rt2 rest ((id, value) :: acc) + +let rec init_instance_fields rt fields acc = + match fields with + | [] -> Ok (rt, List.rev acc) + | (id, typ, init_opt) :: rest -> + let* value, rt1 = + match init_opt with + | Some init_expr -> eval_expr rt init_expr + | None -> + let default = + match typ with + | TypeBase TypeInt -> VInt 0 + | TypeBase TypeBool -> VBool false + | TypeBase TypeChar -> VChar '\x00' + | TypeBase TypeString -> VString "" + | TypeVoid -> VNull + in + return (default, rt) + in + init_instance_fields rt1 rest ((id, value) :: acc) + let init_program (Class (_, name, fields)) = let class_def = class_of_ast (Class ([], name, fields)) in - (* Creating runtime *) let rt = { empty_runtime with class_def = Some class_def } in - (* Program initialization *) - let rec init_fields rt fields acc = - match fields with - | [] -> Ok (rt, List.rev acc) - | (id, typ, init_opt) :: rest -> - (* При инициализации поля, другие поля уже должны быть в окружении *) - let* value, rt1 = - match init_opt with - | Some init_expr -> - (* Здесь init_expr может ссылаться на другие поля *) - eval_expr rt init_expr - | None -> - let default = - match typ with - | TypeBase TypeInt -> VInt 0 - | TypeBase TypeBool -> VBool false - | TypeBase TypeChar -> VChar '\x00' - | TypeBase TypeString -> VString "" - | TypeVoid -> VNull - in - return (default, rt) - in - init_fields rt1 rest ((id, value) :: acc) + + let rt_with_methods = + List.fold_left + (fun rt (id, func) -> { rt with fenv = (id, func) :: rt.fenv }) + rt class_def.methods + in + + let static_fields = + List.filter (fun (_, _, _, is_static) -> is_static) class_def.fields in - let* rt1, fields_list = init_fields rt class_def.fields [] in - (* Creating Program *) + let instance_fields = + List.filter (fun (_, _, _, is_static) -> not is_static) class_def.fields + in + + let strip_static (id, typ, init, _) = (id, typ, init) in + let static_field_infos = List.map strip_static static_fields in + let instance_field_infos = List.map strip_static instance_fields in + + let* rt1, static_vals = + init_static_fields rt_with_methods static_field_infos [] + in + let rt2 = { rt1 with static_fields = static_vals } in + + let* rt3, instance_vals = init_instance_fields rt2 instance_field_infos [] in + let obj_id = 0 in - let program_object = { obj_id; fields = fields_list } in - let rt2 = - { rt1 with objects = [ program_object ]; curr_object = Some obj_id } + let program_object = { obj_id; fields = instance_vals } in + let rt4 = + { rt3 with objects = [ program_object ]; curr_object = Some obj_id } in - Ok (None, rt2) + + Ok (None, rt4) let interpret_program prog = match prog with | Program cls -> ( match init_program cls with | Ok (_, rt) -> ( - (* Find main *) match rt.class_def with | Some class_def -> ( match @@ -487,19 +569,17 @@ let interpret str = | Ok prog -> interpret_program prog | Error e -> Error (OtherError e) -(* TODO: объединить повторы в функции +(* TODO: combine repeated code into functions? unwrap_return *) -(* TODO: errors texts *) - +(* TODO: error messages? *) (* - TODO: класс Program с методами и полями, а также модификаторами - лямбды + что-нибудь с замыканиями - пре и пост ин/декременты - массивы (одномерные) + new - LINQ (простенький в массивы) - async/await (хотя бы без лямбд) - - ФИКС БАГОВ (Тч, парсер (Qt), интерпретатор) + TODO: lambdas + closures + arrays (1D) + new + FIX BUGS (interpreter) + Quicktests for parser (if time permits) + pre/post increment/decrement + LINQ (simple array queries) + async/await (at least without lambdas) *) diff --git a/CSharpStrange/lib/interpret.mli b/CSharpStrange/lib/interpret.mli new file mode 100644 index 00000000..73618212 --- /dev/null +++ b/CSharpStrange/lib/interpret.mli @@ -0,0 +1,36 @@ +(** Copyright 2025, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast + +type interpret_error = + | NotImplemented + | NoVariable of string + | AddressNotFound of int + | VarDeclared of string + | TypeMismatch + | ImpossibleResult of string + | OtherError of string + +type error = IError of interpret_error + +val pp_error : Format.formatter -> error -> unit +val show_error : error -> string + +type adr = Adr of int + +type value = + | VInt of int + | VBool of bool + | VChar of char + | VString of string + | VNull + | VObject of adr + +val pp_value : Format.formatter -> value -> unit +val show_value : value -> string + +(* Main funtions *) +val interpret_program : program -> (value option, interpret_error) result +val interpret : string -> (value option, interpret_error) result diff --git a/CSharpStrange/lib/monads.ml b/CSharpStrange/lib/monads.ml index 0e3a12d3..69930bf8 100644 --- a/CSharpStrange/lib/monads.ml +++ b/CSharpStrange/lib/monads.ml @@ -7,59 +7,55 @@ open Common module STATEERROR = struct type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t - let return : 'a -> ('st, 'a) t = fun x st -> st, Result.Ok x - let fail : 'a -> ('st, 'b) t = fun e st -> st, Result.Error e + let return : 'a -> ('st, 'a) t = fun x st -> (st, Result.Ok x) + let fail : 'a -> ('st, 'b) t = fun e st -> (st, Result.Error e) let ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t = - fun x f st -> + fun x f st -> let st, x = x st in - match x with - | Result.Ok x -> f x st - | Result.Error e -> fail e st - ;; + match x with Result.Ok x -> f x st | Result.Error e -> fail e st - let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = fun x1 x2 -> x1 >>= fun _ -> x2 + let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = + fun x1 x2 -> x1 >>= fun _ -> x2 let ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t = - fun x1 x2 st -> + fun x1 x2 st -> let st, x = x1 st in - match x with - | Result.Ok x -> return x st - | Result.Error _ -> x2 st - ;; + match x with Result.Ok x -> return x st | Result.Error _ -> x2 st let ( >>| ) : ('st, 'a) t -> ('a -> 'b) -> ('st, 'b) t = - fun x f st -> + fun x f st -> let st, x = x st in - match x with - | Result.Ok x -> return (f x) st - | Result.Error e -> fail e st - ;; + match x with Result.Ok x -> return (f x) st | Result.Error e -> fail e st let lift2 : ('a -> 'b -> 'c) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t = - fun f a b -> a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b - ;; - - let lift3 - : ('a -> 'b -> 'c -> 'd) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t -> ('st, 'd) t - = - fun f a b c -> lift2 f a b >>= fun f -> c >>| f - ;; + fun f a b -> + a >>= fun r_a -> + b >>= fun r_b -> return @@ f r_a r_b + + let lift3 : + ('a -> 'b -> 'c -> 'd) -> + ('st, 'a) t -> + ('st, 'b) t -> + ('st, 'c) t -> + ('st, 'd) t = + fun f a b c -> lift2 f a b >>= fun f -> c >>| f let read : ('st, 'st) t = fun st -> return st st - let write : 'st -> ('st, unit) t = fun new_st _ -> new_st, Result.Ok () + let write : 'st -> ('st, unit) t = fun new_st _ -> (new_st, Result.Ok ()) let map : ('a -> ('st, 'b) t) -> 'a list -> ('st, 'b list) t = - fun f list -> - let f acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in + fun f list -> + let f acc el = + acc >>= fun acc -> + f el >>= fun el -> return (el :: acc) + in List.fold_left f (return []) list >>| List.rev - ;; let iter : ('a -> ('st, unit) t) -> 'a list -> ('st, unit) t = - fun f list -> + fun f list -> let f acc elem = acc *> f elem *> return () in List.fold_left f (return ()) list - ;; let run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t = fun f st -> f st end @@ -74,276 +70,50 @@ module TYPECHECK = struct let return_with_fail = function | Some x -> return x | None -> fail (TCError OccursCheck) - ;; - - let read_local : 'a IdMap.t t = - read - >>= function - | _, l, _, _, _ -> return l - ;; + let read_local : 'a IdMap.t t = read >>= function _, l, _, _, _ -> return l let read_local_el id f = read_local >>= fun l -> IdMap.find_opt id l |> f let read_local_el_opt id = read_local_el id return let read_local_el id = read_local_el id return_with_fail let write_local n_l = - read - >>= function - | g, _, n, m, main -> write (g, n_l, n, m, main) - ;; + read >>= function g, _, n, m, main -> write (g, n_l, n, m, main) let write_local_el el_id el_ctx = read_local >>= fun l -> write_local (IdMap.add el_id el_ctx l) - ;; let write_meth_type_opt t = - read - >>= function - | g, l, n, _, main -> write (g, l, n, t, main) - ;; + read >>= function g, l, n, _, main -> write (g, l, n, t, main) let write_meth_type t = write_meth_type_opt (Some t) - - let read_global : 'a IdMap.t t = - read - >>= function - | g, _, _, _, _ -> return g - ;; - + let read_global : 'a IdMap.t t = read >>= function g, _, _, _, _ -> return g let read_global_el id f = read_global >>= fun g -> IdMap.find_opt id g |> f let read_global_el_opt id = read_global_el id return let read_global_el id = read_global_el id return_with_fail let read_meth_type : _type option t = - read - >>= function - | _, _, _, m_t, _ -> return m_t - ;; + read >>= function _, _, _, m_t, _ -> return m_t let read_main_class : class_with_main option t = - read - >>= function - | _, _, _, _, main -> return main - ;; + read >>= function _, _, _, _, main -> return main let write_main_class main = - read - >>= function - | g, l, n, t, _ -> write (g, l, n, t, main) - ;; + read >>= function g, l, n, t, _ -> write (g, l, n, t, main) let write_global n_g = - read - >>= function - | _, l, n, m, main -> write (n_g, l, n, m, main) - ;; + read >>= function _, l, n, m, main -> write (n_g, l, n, m, main) let write_global_el el_id el_ctx = read_global >>= fun g -> write_global (IdMap.add el_id el_ctx g) - ;; let get_curr_class_name : curr_class t = - read - >>= function + read >>= function | _, _, Some n, _, _ -> return n | _ -> - fail (TCError (ImpossibleResult "Current class can be 'none' only before running")) - ;; + fail + (TCError + (ImpossibleResult "Current class can be 'none' only before running")) let write_curr_class_name n = - read - >>= function - | g, l, _, t, main -> write (g, l, Some n, t, main) - ;; -end - -module INTERPRET = struct - open Ast - open Common - open Common.Interpret - - type ('a, 'r) runtime_signal = - | Pipe of 'a - | Return of 'r - - type ('a, 'r, 'e) result = - | Signal of ('a, 'r) runtime_signal - | IError of 'e - - type st = Common.Interpret.state - type ('a, 'r) t = st -> st * ('a, 'r, error) result - - let return : 'a -> ('a, 'r) t = fun x st -> st, Signal (Pipe x) - let fail : 'e -> ('a, 'r) t = fun er st -> st, IError er - let func_return : 'r -> ('a, 'r) t = fun x st -> st, Signal (Return x) - - let ( >>= ) : ('a, 'r) t -> ('a -> ('b, 'r) t) -> ('b, 'r) t = - fun x f st -> - let st, x = x st in - match x with - | Signal (Pipe x) -> f x st - | Signal (Return r) -> func_return r st - | IError er -> fail er st - ;; - - let ( <|> ) : ('a, 'r) t -> ('a, 'r) t -> ('a, 'r) t = - fun x1 x2 st -> - let st, x = x1 st in - match x with - | Signal (Pipe x) -> return x st - | IError _ -> x2 st - | Signal (Return r) -> func_return r st - ;; - - let ( >>| ) : ('a, 'r) t -> ('a -> 'b) -> ('b, 'r) t = - fun x f st -> - let st, x = x st in - match x with - | Signal (Pipe x) -> return (f x) st - | Signal (Return r) -> func_return r st - | IError er -> fail er st - ;; - - let ( *> ) : ('a, 'r) t -> ('b, 'r) t -> ('b, 'r) t = fun x1 x2 -> x1 >>= fun _ -> x2 - - let fold_left f acc l = - let foo acc a = acc >>= fun acc -> f acc a >>= return in - List.fold_left foo (return acc) l - ;; - - let map f list = - let f' acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in - List.fold_left f' (return []) list >>| List.rev - ;; - - let iter f list = - let foo acc el = acc *> f el *> return () in - List.fold_left foo (return ()) list - ;; - - let lift2 f a b = a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b - - let run : ('a, 'r) t -> st * ('a, 'r, error) result = - fun f -> f (IdMap.empty, (Idx 0, IdMap.empty), Adr 0, (Adr 0, AdrMap.empty)) - ;; - - let pipe_adr_with_fail (Adr a) = function - | Some x -> return x - | None -> fail (IError (AddressNotFound a)) - ;; - - let pipe_id_with_fail (Id n) = function - | Some x -> return x - | None -> fail (IError (NoVariable n)) - ;; - - let read : (st, 'r) t = fun st -> return st st - let write : st -> (unit, 'r) t = fun new_st _ -> new_st, Signal (Pipe ()) - - let read_local = - read - >>= function - | _, l, _, _ -> return l - ;; - - let read_local_el f name = read_local >>= fun (_, l) -> IdMap.find_opt name l |> f - let read_local_el_opt name = read_local_el return name - let read_local_el id = read_local_el (pipe_id_with_fail id) id - - let read_local_adr = - read - >>= function - | _, _, adr, _ -> return adr - ;; - - let read_memory = - read - >>= function - | _, _, _, m -> return m - ;; - - let read_memory_obj adr = - read_memory >>= fun (_, m) -> AdrMap.find_opt adr m |> pipe_adr_with_fail adr - ;; - - let write_memory n_m = - read - >>= function - | g, l, adr, _ -> write (g, l, adr, n_m) - ;; - - let write_memory_obj obj_adr obj_ctx = - read_memory >>= fun (adr, m) -> write_memory (adr, AdrMap.add obj_adr obj_ctx m) - ;; - - let write_local n_l = - read - >>= function - | g, _, adr, m -> write (g, n_l, adr, m) - ;; - - let write_local_el el_id el_ctx = - read_local >>= fun (idx, l) -> write_local (idx, IdMap.add el_id el_ctx l) - ;; - - let write_new_local_el (Id el_id) el_ctx = - read_local_el_opt (Id el_id) - >>= function - | Some _ -> fail (IError (VarDeclared el_id)) - | None -> write_local_el (Id el_id) el_ctx - ;; - - let read_global = - read - >>= function - | g, _, _, _ -> return g - ;; - - let read_global_el name = - read_global >>= fun g -> IdMap.find_opt name g |> pipe_id_with_fail name - ;; - - let write_global n_g = - read - >>= function - | _, l, adr, m -> write (n_g, l, adr, m) - ;; - - let write_global_el el_name el_ctx = - read_global >>= fun g -> write_global (IdMap.add el_name el_ctx g) - ;; - - let find_local_el id = - let rec find_memory_obj adr = - read_memory_obj adr - >>= fun obj -> - IdMap.find_opt id obj.mems - |> function - | Some (_, vl) -> return (Value (vl, None)) - | None -> - (match obj.p_adr with - | Some p_adr -> find_memory_obj p_adr - | None -> fail (IError TypeMismatch)) - in - let find_global_el adr = - let f acc = function - | IMethod (m, b) when equal_ident m.m_id id -> - return (Some (Code (IMethod (m, b)))) - | _ -> return acc - in - read_memory_obj adr - >>= fun obj -> - read_global_el obj.cl_name - >>= function - | IntrClass cl -> - fold_left f None cl.cl_body - >>= (function - | Some vl -> return vl - | None -> - (match id with - | Id n -> fail (IError (NoVariable n)))) - in - read_local_el id - <|> (read_local_adr >>= fun adr -> find_memory_obj adr <|> find_global_el adr) - ;; + read >>= function g, l, _, t, main -> write (g, l, Some n, t, main) end diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 3c5bb370..13aeae51 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -2,8 +2,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -(* TODO: refactor!! *) - open Ast open Monads.TYPECHECK open Common diff --git a/CSharpStrange/tests/dune b/CSharpStrange/tests/dune index 5c193b44..dd8efe55 100644 --- a/CSharpStrange/tests/dune +++ b/CSharpStrange/tests/dune @@ -1,7 +1,7 @@ (library (name tests) (public_name CSharpStrange.Lib.Tests) - (modules Parser_tests Pp_tests Typecheck_tests Qt_tests) + (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests Qt_tests) (libraries angstrom c_sharp_strange_lib qcheck) (inline_tests) (instrumentation diff --git a/CSharpStrange/tests/interpret_tests.ml b/CSharpStrange/tests/interpret_tests.ml index ab49732e..60677a87 100644 --- a/CSharpStrange/tests/interpret_tests.ml +++ b/CSharpStrange/tests/interpret_tests.ml @@ -3,46 +3,50 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Interpret -open C_sharp_strange_lib.Monad -open C_sharp_strange_lib.Common.Interpret +open C_sharp_strange_lib.Monads let show_wrap str = match interpret str with - | Result.Ok x -> - (match x with - | Some x -> Format.printf "Result: '%a'" pp_vl x - | None -> Format.print_string "Result: void\n") - | Result.Error er -> Format.printf "%a\n%!" pp_error er -;; + | Result.Ok x -> ( + match x with + | Some x -> Format.printf "Result: '%a'" pp_value x + | None -> Format.print_string "Result: void\n") + | Result.Error er -> Format.printf "%a\n%!" pp_error (IError er) +(* TODO: incluede TC? *) -let%expect_test _ = +let%expect_test "Main 1" = show_wrap {| class Program { - int b = 9; - int c = 67; - int a; - bool r = false; - string s = "ok"; - char h = 'a'; - bool t; + static int b = 9; + static int c = 67; + static int a; + static bool r = false; + static string s = "ok"; + static char h = 'a'; + static bool t; - static int Main() { + static int Main() { a = (50 % 2) + b - c; r = s != "kkkk" && (190%22 == 100 * -2/5); t = (a != b * c) || (a >= b) && (a == c +90); return a; } + } |}; [%expect {| - Result: '(Init (IValue (VInt -58)))' |}] -;; + Result: '-58' |}] + +(* TODO: Доступ к нестатическим полям из статического метода запрещен + В статическом классе только статические методы, но static не может быть входом в программу + Мб сделать проверку на класс внутри main, но не успею +*) -let%expect_test _ = +let%expect_test "Main 2" = show_wrap {| class Program { - int n = 10; + static int n = 10; static int Main() { int res = 0; for(int i = 0; i < n; i = i+1) { @@ -54,15 +58,15 @@ let%expect_test _ = } } |}; [%expect {| - Result: '(Init (IValue (VInt 870)))' |}] -;; + Result: '870' |}] +(* TODO: n without static *) -let%expect_test _ = +let%expect_test "Main 3" = show_wrap {| class Program { - bool t; - int a = 5; + static bool t; + static int a = 5; static int Main() { int b = 5; @@ -85,15 +89,14 @@ let%expect_test _ = } } |}; [%expect {| - Result: '(Init (IValue (VInt 141)))' |}] -;; + Result: '141' |}] -let%expect_test _ = +let%expect_test "Main 4" = show_wrap {| class Program { - int x = 189; - int s = 0; + static int x = 189; + static int s = 0; static int Main() { while (x != 0) { s = s + x % 10; @@ -103,14 +106,13 @@ let%expect_test _ = } } |}; [%expect {| - Result: '(Init (IValue (VInt 18)))' |}] -;; + Result: '18' |}] -let%expect_test _ = +let%expect_test "Functions 1" = show_wrap {| class Program { - public int is_right_triangle(int a, int b, int c) { + public static int is_right_triangle(int a, int b, int c) { if ((a + b <= c) || (a + c <= b) || (b + c <= a)) { return 0; } else if ((a * a + b * b == c * c) || (a * a + c * c == b * b) || (b * b + c * c == a * a)) { @@ -124,11 +126,10 @@ let%expect_test _ = } } |}; [%expect {| - Result: '(Init (IValue (VInt 1)))' |}] -;; + Result: '1' |}] +(* TODO: не static нельзя *) - -let%expect_test _ = +let%expect_test "Invalid value" = show_wrap {| class Program { @@ -138,5 +139,5 @@ let%expect_test _ = return b; } } |}; - [%expect {| (Interpret_error (Other "Value is not initialized")) |}] -;; + [%expect {| + (IError (OtherError "Value is not initialized"))|}] From d8c6419b049b1e74259579d28bd32620b4adf330 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 20:12:23 +0300 Subject: [PATCH 38/84] style: ocamlformat Signed-off-by: f1i3g3 --- CSharpStrange/.ocamlformat | 2 + CSharpStrange/bin/REPL.ml | 37 +- CSharpStrange/lib/ast.ml | 110 ++-- CSharpStrange/lib/common.ml | 47 +- CSharpStrange/lib/common.mli | 56 +- CSharpStrange/lib/interpret.ml | 710 +++++++++++++----------- CSharpStrange/lib/monads.ml | 121 ++-- CSharpStrange/lib/parser.ml | 280 +++++----- CSharpStrange/lib/prettyprinter.ml | 3 +- CSharpStrange/lib/typecheck.ml | 391 +++++++------ CSharpStrange/tests/interpret_tests.ml | 22 +- CSharpStrange/tests/interpret_tests.mli | 2 +- CSharpStrange/tests/parser_tests.ml | 418 +++++++------- CSharpStrange/tests/qt_tests.ml | 340 ++++++------ CSharpStrange/tests/typecheck_tests.ml | 22 +- 15 files changed, 1367 insertions(+), 1194 deletions(-) create mode 100644 CSharpStrange/.ocamlformat diff --git a/CSharpStrange/.ocamlformat b/CSharpStrange/.ocamlformat new file mode 100644 index 00000000..7fd0ea01 --- /dev/null +++ b/CSharpStrange/.ocamlformat @@ -0,0 +1,2 @@ +profile=janestreet +version=0.26.2 \ No newline at end of file diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange/bin/REPL.ml index 89da7505..05e451b5 100644 --- a/CSharpStrange/bin/REPL.ml +++ b/CSharpStrange/bin/REPL.ml @@ -9,22 +9,21 @@ open C_sharp_strange_lib.Common open Printf open Stdio -type opts = { - mutable dump_parse_tree : bool; - mutable file_path : string option; - mutable eval : bool; -} +type opts = + { mutable dump_parse_tree : bool + ; mutable file_path : string option + ; mutable eval : bool + } let () = let opts = { dump_parse_tree = false; file_path = None; eval = false } in let _ = Arg.parse - [ - ("-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n"); - ( "-filepath", - Arg.String (fun file_path -> opts.file_path <- Some file_path), - "Input code in file\n" ); - ("-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n"); + [ "-parseast", Arg.Unit (fun () -> opts.dump_parse_tree <- true), "\n" + ; ( "-filepath" + , Arg.String (fun file_path -> opts.file_path <- Some file_path) + , "Input code in file\n" ) + ; "-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n" ] (fun _ -> Stdlib.Format.eprintf "Something got wrong\n"; @@ -37,11 +36,13 @@ let () = | Some path -> String.trim @@ In_channel.read_all path in match apply_parser parse_prog path with - | Ok ast -> ( - if opts.dump_parse_tree then print_endline (show_program ast); - if opts.eval then - match interpret_program ast with - | Ok (Some v) -> printf "Result: %s\n" (show_value v) - | Ok None -> printf "Result: void\n" - | Error _ -> failwith (sprintf "Interpretation error: %s" "TODO")) + | Ok ast -> + if opts.dump_parse_tree then print_endline (show_program ast); + if opts.eval + then ( + match interpret_program ast with + | Ok (Some v) -> printf "Result: %s\n" (show_value v) + | Ok None -> printf "Result: void\n" + | Error _ -> failwith (sprintf "Interpretation error: %s" "TODO")) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) +;; diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange/lib/ast.ml index 03fde91c..06fdaa46 100644 --- a/CSharpStrange/lib/ast.ml +++ b/CSharpStrange/lib/ast.ml @@ -4,11 +4,11 @@ (** Values types *) type val_type = - | ValInt of int (** Int value *) - | ValChar of char (** Char value *) - | ValNull (** Null *) - | ValBool of bool (** Bool value *) - | ValString of string (** string value *) + | ValInt of int (** Int value *) + | ValChar of char (** Char value *) + | ValNull (** Null *) + | ValBool of bool (** Bool value *) + | ValString of string (** string value *) [@@deriving eq, show { with_path = false }] (** Identidicator *) @@ -16,16 +16,16 @@ type ident = Id of string [@@deriving eq, show { with_path = false }] (** Basic types declarations *) type base_type = - | TypeInt (** Declaration of int *) - | TypeChar (** Declaration of char *) - | TypeBool (** Declaration of bool *) - | TypeString (** Declaration of string *) + | TypeInt (** Declaration of int *) + | TypeChar (** Declaration of char *) + | TypeBool (** Declaration of bool *) + | TypeString (** Declaration of string *) [@@deriving eq, show { with_path = false }] (** Type delcaration *) type _type = - | TypeBase of base_type (** Declaration of basic type *) - | TypeVoid (** Declaration of void *) + | TypeBase of base_type (** Declaration of basic type *) + | TypeVoid (** Declaration of void *) [@@deriving eq, show { with_path = false }] (** Variable *) @@ -33,37 +33,36 @@ type var_type = TypeVar of _type [@@deriving eq, show { with_path = false }] (** Modifiers *) type modifier = - | MPublic (** Public modifier, used for main() method only *) - | MStatic (** Static modifier, used for main() method only *) - | MAsync (** Async modifier *) + | MPublic (** Public modifier, used for main() method only *) + | MStatic (** Static modifier, used for main() method only *) + | MAsync (** Async modifier *) [@@deriving eq, show { with_path = false }] -type var_decl = Var of var_type * ident -[@@deriving eq, show { with_path = false }] - -type params = Params of var_decl list -[@@deriving eq, show { with_path = false }] +type var_decl = Var of var_type * ident [@@deriving eq, show { with_path = false }] +type params = Params of var_decl list [@@deriving eq, show { with_path = false }] (** Binary operations *) type bin_op = - | OpAdd (** Sum: a [+] b *) - | OpSub (** a [-] b *) - | OpMul (** a [*] b *) - | OpDiv (** a [/] b in integers *) - | OpMod (** a [%] b *) - | OpEqual (** a [==] b *) - | OpNonEqual (** a [!=] b *) - | OpLess (** a [<] b *) - | OpMore (** a [>] b *) - | OpLessEqual (** a [<=] b *) - | OpMoreEqual (** a [>=] b *) - | OpAnd (** a [&&] b *) - | OpOr (** a [||] b *) - | OpAssign (** a [=] b *) + | OpAdd (** Sum: a [+] b *) + | OpSub (** a [-] b *) + | OpMul (** a [*] b *) + | OpDiv (** a [/] b in integers *) + | OpMod (** a [%] b *) + | OpEqual (** a [==] b *) + | OpNonEqual (** a [!=] b *) + | OpLess (** a [<] b *) + | OpMore (** a [>] b *) + | OpLessEqual (** a [<=] b *) + | OpMoreEqual (** a [>=] b *) + | OpAnd (** a [&&] b *) + | OpOr (** a [||] b *) + | OpAssign (** a [=] b *) [@@deriving eq, show { with_path = false }] (** Unary operations *) -type un_op = OpNeg (** [-] a *) | OpNot (** [!] a *) +type un_op = + | OpNeg (** [-] a *) + | OpNot (** [!] a *) [@@deriving eq, show { with_path = false }] (** From clauses *) @@ -72,13 +71,13 @@ type from_clause = FromClause of string * ident (** Language expressions *) type expr = - | EValue of val_type (** Some value *) - | EBinOp of bin_op * expr * expr (** Binary operation *) - | EUnOp of un_op * expr (** Unary operation *) - | EId of ident (** Identificator expression *) - | EArrayAccess of expr * expr (** Array access: a = arr[i] *) - | EFuncCall of expr * args (** Call of function: name(arguments) *) - | EAwait of expr (** [Await] expression *) + | EValue of val_type (** Some value *) + | EBinOp of bin_op * expr * expr (** Binary operation *) + | EUnOp of un_op * expr (** Unary operation *) + | EId of ident (** Identificator expression *) + | EArrayAccess of expr * expr (** Array access: a = arr[i] *) + | EFuncCall of expr * args (** Call of function: name(arguments) *) + | EAwait of expr (** [Await] expression *) [@@deriving eq, show { with_path = false }] and args = Args of expr list [@@deriving show { with_path = false }] @@ -86,32 +85,29 @@ and args = Args of expr list [@@deriving show { with_path = false }] (** Language statements *) type stmt = | SFor of stmt option * expr option * expr option * stmt - (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) + (** For cycle: [for] (int i = 0, j = 3; i < 4; i++, j--) \{\} *) | SIf of expr * stmt * stmt option - (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) - | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) - | SReturn of expr option (** Return: [return] (a) *) - | SBlock of stmt list - (** Block of statements: \{ a \}; could be empty: \{\} *) - | SBreak (** Cycle [break] *) - | SContinue (** Cycle [continue] *) - | SExpr of expr (** Another expression *) - | SDecl of var_decl * expr option (** Var declaration *) + (** If condition: [if] (a) [then] \{ b \} ([else] \{ c \} ) *) + | SWhile of expr * stmt (** While cycle: [while] (a) \{ \} *) + | SReturn of expr option (** Return: [return] (a) *) + | SBlock of stmt list (** Block of statements: \{ a \}; could be empty: \{\} *) + | SBreak (** Cycle [break] *) + | SContinue (** Cycle [continue] *) + | SExpr of expr (** Another expression *) + | SDecl of var_decl * expr option (** Var declaration *) [@@deriving eq, show { with_path = false }] (** C Sharp class fields *) type field = | VarField of modifier list * var_type * ident * expr option - (** Class field - always initialized *) - | Method of modifier list * _type * ident * params * stmt (** Class method *) + (** Class field - always initialized *) + | Method of modifier list * _type * ident * params * stmt (** Class method *) [@@deriving eq, show { with_path = false }] (** C Sharp class *) type c_sharp_class = - | Class of modifier list * ident * field list - (** Basic class (Program) name *) + | Class of modifier list * ident * field list (** Basic class (Program) name *) [@@deriving eq, show { with_path = false }] (** Program AST *) -type program = Program of c_sharp_class -[@@deriving eq, show { with_path = false }] +type program = Program of c_sharp_class [@@deriving eq, show { with_path = false }] diff --git a/CSharpStrange/lib/common.ml b/CSharpStrange/lib/common.ml index 4e8f707a..9958a5cc 100644 --- a/CSharpStrange/lib/common.ml +++ b/CSharpStrange/lib/common.ml @@ -23,7 +23,9 @@ type interpret_error = | OtherError of string [@@deriving show { with_path = false }] -type error = TCError of tc_error | IError of interpret_error +type error = + | TCError of tc_error + | IError of interpret_error [@@deriving show { with_path = false }] module Id = struct @@ -44,27 +46,30 @@ end module AdrMap = Map.Make (Adr) -type var_info = { var_type : var_type; initialized : bool (* TODO: ?? *) } +type var_info = + { var_type : var_type + ; initialized : bool (* TODO: ?? *) + } [@@deriving show { with_path = false }, eq] -type field_info = { - field_modifiers : modifier list; - field_type : var_type; - field_name : ident; - field_init : expr option; - is_static : bool; -} +type field_info = + { field_modifiers : modifier list + ; field_type : var_type + ; field_name : ident + ; field_init : expr option + ; is_static : bool + } [@@deriving show { with_path = false }, eq] -type method_info = { - method_modifiers : modifier list; - method_return : _type; - method_name : ident; - method_params : params; - method_body : stmt; - is_static : bool; - is_main : bool; -} +type method_info = + { method_modifiers : modifier list + ; method_return : _type + ; method_name : ident + ; method_params : params + ; method_body : stmt + ; is_static : bool + ; is_main : bool + } [@@deriving show { with_path = false }, eq] type obj_content = @@ -82,9 +87,5 @@ module TypeCheck = struct type class_with_main = ident type state = - global_env - * local_env - * curr_class option - * _type option - * class_with_main option + global_env * local_env * curr_class option * _type option * class_with_main option end diff --git a/CSharpStrange/lib/common.mli b/CSharpStrange/lib/common.mli index f021b1dc..9842da74 100644 --- a/CSharpStrange/lib/common.mli +++ b/CSharpStrange/lib/common.mli @@ -30,7 +30,9 @@ val pp_interpret_error : Format.formatter -> interpret_error -> unit val show_interpret_error : interpret_error -> string (** Combined error type *) -type error = TCError of tc_error | IError of interpret_error +type error = + | TCError of tc_error + | IError of interpret_error val pp_error : Format.formatter -> error -> unit val show_error : error -> string @@ -65,39 +67,39 @@ module AdrMap : sig include Map.S with type key = adr end -type var_info = { - var_type : var_type; - initialized : bool; (** Whether the variable has been initialized *) -} (** Variable information for type checker *) +type var_info = + { var_type : var_type + ; initialized : bool (** Whether the variable has been initialized *) + } val pp_var_info : Format.formatter -> var_info -> unit val show_var_info : var_info -> string val equal_var_info : var_info -> var_info -> bool -type field_info = { - field_modifiers : modifier list; - field_type : var_type; - field_name : ident; - field_init : expr option; - is_static : bool; -} (** Field information for type checker *) +type field_info = + { field_modifiers : modifier list + ; field_type : var_type + ; field_name : ident + ; field_init : expr option + ; is_static : bool + } val pp_field_info : Format.formatter -> field_info -> unit val show_field_info : field_info -> string val equal_field_info : field_info -> field_info -> bool -type method_info = { - method_modifiers : modifier list; - method_return : _type; - method_name : ident; - method_params : params; - method_body : stmt; - is_static : bool; - is_main : bool; (** Whether this is the Main method *) -} (** Method information for type checker *) +type method_info = + { method_modifiers : modifier list + ; method_return : _type + ; method_name : ident + ; method_params : params + ; method_body : stmt + ; is_static : bool + ; is_main : bool (** Whether this is the Main method *) + } val pp_method_info : Format.formatter -> method_info -> unit val show_method_info : method_info -> string @@ -105,9 +107,9 @@ val equal_method_info : method_info -> method_info -> bool (** Type checker content types *) type obj_content = - | TCLocalVar of var_info (** Local variable *) - | TCField of field_info (** Class field *) - | TCMethod of method_info (** Class method *) + | TCLocalVar of var_info (** Local variable *) + | TCField of field_info (** Class field *) + | TCMethod of method_info (** Class method *) val pp_obj_content : Format.formatter -> obj_content -> unit val show_obj_content : obj_content -> string @@ -124,9 +126,5 @@ module TypeCheck : sig type class_with_main = ident type state = - global_env - * local_env - * curr_class option - * _type option - * class_with_main option + global_env * local_env * curr_class option * _type option * class_with_main option end diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange/lib/interpret.ml index 0de64012..ec437a59 100644 --- a/CSharpStrange/lib/interpret.ml +++ b/CSharpStrange/lib/interpret.ml @@ -24,10 +24,10 @@ type 'a res = ('a, interpret_error) result type adr = Adr of int [@@deriving show { with_path = false }] module IdMap = Map.Make (struct - type t = ident + type t = ident - let compare = compare -end) + let compare = compare + end) module LocMap = Map.Make (Int) @@ -40,32 +40,49 @@ type value = | VObject of adr [@@deriving show { with_path = false }] -and func = { params : ident list; body : stmt } +and func = + { params : ident list + ; body : stmt + } type location = int -type var_info = { loc : location; initialized : bool } + +type var_info = + { loc : location + ; initialized : bool + } + type env = var_info IdMap.t list type func_env = (ident * func) list -type store = { mem : value LocMap.t; next_loc : int } + +type store = + { mem : value LocMap.t + ; next_loc : int + } + type object_id = int type field_value = value -type object_state = { obj_id : object_id; fields : (ident * field_value) list } - -type class_def = { - name : ident; - fields : (ident * _type * expr option * bool) list; - methods : (ident * func) list; -} - -type runtime = { - env : env; - fenv : func_env; - store : store; - objects : object_state list; - curr_object : object_id option; - class_def : class_def option; - static_fields : (ident * value) list; -} + +type object_state = + { obj_id : object_id + ; fields : (ident * field_value) list + } + +type class_def = + { name : ident + ; fields : (ident * _type * expr option * bool) list + ; methods : (ident * func) list + } + +type runtime = + { env : env + ; fenv : func_env + ; store : store + ; objects : object_state list + ; curr_object : object_id option + ; class_def : class_def option + ; static_fields : (ident * value) list + } let rec pp_value fmt = function | VInt i -> Format.fprintf fmt "%d" i @@ -74,69 +91,81 @@ let rec pp_value fmt = function | VString s -> Format.fprintf fmt "\"%s\"" s | VNull -> Format.fprintf fmt "null" | VObject (Adr a) -> Format.fprintf fmt "object@%d" a +;; -type exec_result = Normal | Return of value | Break | Continue +type exec_result = + | Normal + | Return of value + | Break + | Continue let empty_runtime = - { - env = [ IdMap.empty ]; - fenv = []; - store = { next_loc = 0; mem = LocMap.empty }; - objects = []; - curr_object = None; - class_def = None; - static_fields = []; + { env = [ IdMap.empty ] + ; fenv = [] + ; store = { next_loc = 0; mem = LocMap.empty } + ; objects = [] + ; curr_object = None + ; class_def = None + ; static_fields = [] } +;; let string_of_ident (Id s) = s let rec lookup_env id = function | [] -> Error (NoVariable ("variable not found: " ^ string_of_ident id)) - | scope :: rest -> ( - match IdMap.find_opt id scope with - | Some var_info -> Ok var_info.loc - | None -> lookup_env id rest) + | scope :: rest -> + (match IdMap.find_opt id scope with + | Some var_info -> Ok var_info.loc + | None -> lookup_env id rest) +;; let check_initialized id env = let rec find_var = function | [] -> Error (NoVariable (string_of_ident id)) - | scope :: rest -> ( - match IdMap.find_opt id scope with - | Some var_info -> - if var_info.initialized then Ok () - else Error (OtherError "Value is not initialized") - | None -> find_var rest) + | scope :: rest -> + (match IdMap.find_opt id scope with + | Some var_info -> + if var_info.initialized + then Ok () + else Error (OtherError "Value is not initialized") + | None -> find_var rest) in find_var env +;; let mark_initialized id env = let rec mark_in_scope = function | [] -> [] - | scope :: rest -> ( - match IdMap.find_opt id scope with - | Some var_info -> - let new_var_info = { var_info with initialized = true } in - IdMap.add id new_var_info scope :: rest - | None -> scope :: mark_in_scope rest) + | scope :: rest -> + (match IdMap.find_opt id scope with + | Some var_info -> + let new_var_info = { var_info with initialized = true } in + IdMap.add id new_var_info scope :: rest + | None -> scope :: mark_in_scope rest) in mark_in_scope env +;; let rec lookup_func_opt (id : ident) = function | [] -> None | (id1, v) :: _ when id1 = id -> Some v | _ :: rest -> lookup_func_opt id rest +;; let lookup_store l store = match LocMap.find_opt l store.mem with | Some v -> Ok v | None -> Error (AddressNotFound l) +;; let update_store l v store = { store with mem = LocMap.add l v store.mem } let alloc v store = let loc = store.next_loc in let store = { mem = LocMap.add loc v store.mem; next_loc = loc + 1 } in - (loc, store) + loc, store +;; let lookup_env_r (id : ident) (rt : runtime) = lookup_env id rt.env let lookup_store_r l rt = lookup_store l rt.store @@ -144,7 +173,8 @@ let update_store_r l v rt = { rt with store = update_store l v rt.store } let alloc_r v rt = let loc, store2 = alloc v rt.store in - (loc, { rt with store = store2 }) + loc, { rt with store = store2 } +;; let value_of_val_type = function | ValInt i -> VInt i @@ -152,179 +182,205 @@ let value_of_val_type = function | ValBool b -> VBool b | ValString s -> VString s | ValNull -> VNull +;; + +let string_of_ident = function + | Id s -> s +;; + +let ident_of_vardecl = function + | Var (_, id) -> id +;; + +let expect_bool = function + | VBool b -> Ok b + | _ -> Error TypeMismatch +;; -let string_of_ident = function Id s -> s -let ident_of_vardecl = function Var (_, id) -> id -let expect_bool = function VBool b -> Ok b | _ -> Error TypeMismatch -let expect_int = function VInt i -> Ok i | _ -> Error TypeMismatch +let expect_int = function + | VInt i -> Ok i + | _ -> Error TypeMismatch +;; let add_var (id : ident) (loc : location) (env : env) = match env with | scope :: rest -> - let var_info = { loc; initialized = false } in - Ok (IdMap.add id var_info scope :: rest) + let var_info = { loc; initialized = false } in + Ok (IdMap.add id var_info scope :: rest) | [] -> Error (VarDeclared (string_of_ident id)) +;; let push_scope env = Ok (IdMap.empty :: env) let pop_scope = function | _ :: rest -> Ok rest | [] -> Error (OtherError "cannot pop scope") +;; let var_field_of_ast = function | VarField (mods, TypeVar typ, id, init) -> - Some - ( id, - typ, - init, - List.exists (function MStatic -> true | _ -> false) mods ) + Some + ( id + , typ + , init + , List.exists + (function + | MStatic -> true + | _ -> false) + mods ) | Method _ -> None +;; let method_of_ast = function | Method (mods, ret_type, id, Params params, body) -> - let params_list = List.map (fun (Var (_, id)) -> id) params in - Some (id, { params = params_list; body }) + let params_list = List.map (fun (Var (_, id)) -> id) params in + Some (id, { params = params_list; body }) | VarField _ -> None +;; let class_of_ast (Class (mods, name, fields)) = let fields_list = List.filter_map var_field_of_ast fields in let methods_list = List.filter_map method_of_ast fields in { name; fields = fields_list; methods = methods_list } +;; let find_field obj_id field_id rt = match List.find_opt (fun o -> o.obj_id = obj_id) rt.objects with | None -> Error (OtherError "object not found") - | Some obj -> ( - match List.find_opt (fun (id, _) -> id = field_id) obj.fields with - | Some (_, v) -> Ok v - | None -> Error (OtherError "field not found")) + | Some obj -> + (match List.find_opt (fun (id, _) -> id = field_id) obj.fields with + | Some (_, v) -> Ok v + | None -> Error (OtherError "field not found")) +;; let update_field obj_id field_id new_value rt = let rec update_obj_list = function | [] -> [] | obj :: rest when obj.obj_id = obj_id -> - let new_fields = - List.map - (fun (id, v) -> if id = field_id then (id, new_value) else (id, v)) - obj.fields - in - { obj with fields = new_fields } :: rest + let new_fields = + List.map + (fun (id, v) -> if id = field_id then id, new_value else id, v) + obj.fields + in + { obj with fields = new_fields } :: rest | obj :: rest -> obj :: update_obj_list rest in { rt with objects = update_obj_list rt.objects } +;; let find_static_field field_id rt = match List.find_opt (fun (id, _) -> id = field_id) rt.static_fields with | Some (_, v) -> Ok v | None -> Error (NoVariable (string_of_ident field_id)) +;; let update_static_field field_id new_value rt = let rec update_static_list = function - | [] -> [ (field_id, new_value) ] + | [] -> [ field_id, new_value ] | (id, v) :: rest when id = field_id -> (id, new_value) :: rest | (id, v) :: rest -> (id, v) :: update_static_list rest in { rt with static_fields = update_static_list rt.static_fields } +;; let rec eval_expr (rt : runtime) = function | EValue v -> return (value_of_val_type v, rt) - | EId id -> ( - match lookup_env id rt.env with - | Ok loc -> ( - match check_initialized id rt.env with - | Ok () -> - let* v = lookup_store_r loc rt in - return (v, rt) - | Error e -> Error e) - | Error _ -> ( - match find_static_field id rt with - | Ok v -> return (v, rt) - | Error _ -> ( - match rt.curr_object with - | None -> Error (NoVariable (string_of_ident id)) - | Some obj_id -> ( - match find_field obj_id id rt with - | Ok v -> return (v, rt) - | Error e -> Error e)))) - | EBinOp (OpAssign, left, right) -> ( - let* v, rt1 = eval_expr rt right in - match left with - | EId id -> ( - match lookup_env id rt1.env with - | Ok loc -> - let new_env = mark_initialized id rt1.env in - let rt2 = { rt1 with env = new_env } in - let rt3 = update_store_r loc v rt2 in - return (v, rt3) - | Error _ -> ( - match find_static_field id rt1 with - | Ok _ -> - let rt2 = update_static_field id v rt1 in - return (v, rt2) - | Error _ -> ( - match rt1.curr_object with - | None -> - Error - (OtherError ("cannot assign to " ^ string_of_ident id)) - | Some obj_id -> - let rt2 = update_field obj_id id v rt1 in - return (v, rt2)))) - | _ -> Error TypeMismatch) - | EBinOp (OpAnd, e1, e2) -> ( - let* v1, rt1 = eval_expr rt e1 in - match v1 with - | VBool false -> return (VBool false, rt1) - | VBool true -> ( - let* v2, rt2 = eval_expr rt1 e2 in - match v2 with - | VBool b -> return (VBool b, rt2) - | _ -> Error TypeMismatch) - | _ -> Error TypeMismatch) - | EBinOp (OpOr, e1, e2) -> ( - let* v1, rt1 = eval_expr rt e1 in - match v1 with - | VBool true -> return (VBool true, rt1) - | VBool false -> ( - let* v2, rt2 = eval_expr rt1 e2 in - match v2 with - | VBool b -> return (VBool b, rt2) - | _ -> Error TypeMismatch) - | _ -> Error TypeMismatch) + | EId id -> + (match lookup_env id rt.env with + | Ok loc -> + (match check_initialized id rt.env with + | Ok () -> + let* v = lookup_store_r loc rt in + return (v, rt) + | Error e -> Error e) + | Error _ -> + (match find_static_field id rt with + | Ok v -> return (v, rt) + | Error _ -> + (match rt.curr_object with + | None -> Error (NoVariable (string_of_ident id)) + | Some obj_id -> + (match find_field obj_id id rt with + | Ok v -> return (v, rt) + | Error e -> Error e)))) + | EBinOp (OpAssign, left, right) -> + let* v, rt1 = eval_expr rt right in + (match left with + | EId id -> + (match lookup_env id rt1.env with + | Ok loc -> + let new_env = mark_initialized id rt1.env in + let rt2 = { rt1 with env = new_env } in + let rt3 = update_store_r loc v rt2 in + return (v, rt3) + | Error _ -> + (match find_static_field id rt1 with + | Ok _ -> + let rt2 = update_static_field id v rt1 in + return (v, rt2) + | Error _ -> + (match rt1.curr_object with + | None -> Error (OtherError ("cannot assign to " ^ string_of_ident id)) + | Some obj_id -> + let rt2 = update_field obj_id id v rt1 in + return (v, rt2)))) + | _ -> Error TypeMismatch) + | EBinOp (OpAnd, e1, e2) -> + let* v1, rt1 = eval_expr rt e1 in + (match v1 with + | VBool false -> return (VBool false, rt1) + | VBool true -> + let* v2, rt2 = eval_expr rt1 e2 in + (match v2 with + | VBool b -> return (VBool b, rt2) + | _ -> Error TypeMismatch) + | _ -> Error TypeMismatch) + | EBinOp (OpOr, e1, e2) -> + let* v1, rt1 = eval_expr rt e1 in + (match v1 with + | VBool true -> return (VBool true, rt1) + | VBool false -> + let* v2, rt2 = eval_expr rt1 e2 in + (match v2 with + | VBool b -> return (VBool b, rt2) + | _ -> Error TypeMismatch) + | _ -> Error TypeMismatch) | EBinOp (op, e1, e2) -> - let* v1, rt1 = eval_expr rt e1 in - let* v2, rt2 = eval_expr rt1 e2 in - eval_binop op v1 v2 rt2 - | EUnOp (OpNot, e) -> ( - let* v, rt1 = eval_expr rt e in - match v with - | VBool b -> return (VBool (not b), rt1) - | _ -> Error TypeMismatch) - | EUnOp (OpNeg, e) -> ( - let* v, rt1 = eval_expr rt e in - match v with VInt i -> return (VInt (-i), rt1) | _ -> Error TypeMismatch) - | EFuncCall (fn_expr, Args args) -> ( - match fn_expr with - | EId id -> ( - match lookup_func_opt id rt.fenv with - | None -> - Error (OtherError ("function not found: " ^ string_of_ident id)) - | Some f -> - let rec eval_args rt = function - | [] -> return ([], rt) - | e :: rest -> - let* v, rt1 = eval_expr rt e in - let* vs, rt2 = eval_args rt1 rest in - return (v :: vs, rt2) - in - let* arg_vals, rt2 = eval_args rt args in - let* v, rt3 = call_function rt2 f arg_vals in - return (v, rt3)) - | _ -> Error (OtherError "invalid function call")) + let* v1, rt1 = eval_expr rt e1 in + let* v2, rt2 = eval_expr rt1 e2 in + eval_binop op v1 v2 rt2 + | EUnOp (OpNot, e) -> + let* v, rt1 = eval_expr rt e in + (match v with + | VBool b -> return (VBool (not b), rt1) + | _ -> Error TypeMismatch) + | EUnOp (OpNeg, e) -> + let* v, rt1 = eval_expr rt e in + (match v with + | VInt i -> return (VInt (-i), rt1) + | _ -> Error TypeMismatch) + | EFuncCall (fn_expr, Args args) -> + (match fn_expr with + | EId id -> + (match lookup_func_opt id rt.fenv with + | None -> Error (OtherError ("function not found: " ^ string_of_ident id)) + | Some f -> + let rec eval_args rt = function + | [] -> return ([], rt) + | e :: rest -> + let* v, rt1 = eval_expr rt e in + let* vs, rt2 = eval_args rt1 rest in + return (v :: vs, rt2) + in + let* arg_vals, rt2 = eval_args rt args in + let* v, rt3 = call_function rt2 f arg_vals in + return (v, rt3)) + | _ -> Error (OtherError "invalid function call")) | EArrayAccess _ -> Error NotImplemented | EAwait _ -> Error NotImplemented and eval_binop op v1 v2 rt : (value * runtime) res = - match (op, v1, v2) with + match op, v1, v2 with | OpAdd, VInt a, VInt b -> return (VInt (a + b), rt) | OpSub, VInt a, VInt b -> return (VInt (a - b), rt) | OpMul, VInt a, VInt b -> return (VInt (a * b), rt) @@ -346,17 +402,17 @@ and call_function (rt : runtime) f args = let caller_env = rt.env in let caller_obj = rt.curr_object in let rec bind_params env params args rt = - match (params, args) with + match params, args with | [], [] -> return ({ rt with env }, rt) | p :: ps, v :: vs -> - let loc, rt1 = alloc_r v rt in - let var_info = { loc; initialized = true } in - let* env2 = - match env with - | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) - | [] -> Error (OtherError "empty environment in bind_params") - in - bind_params env2 ps vs rt1 + let loc, rt1 = alloc_r v rt in + let var_info = { loc; initialized = true } in + let* env2 = + match env with + | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) + | [] -> Error (OtherError "empty environment in bind_params") + in + bind_params env2 ps vs rt1 | _ -> Error (OtherError "argument mismatch") in let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in @@ -370,204 +426,204 @@ and call_function (rt : runtime) f args = and exec_stmt (rt : runtime) = function | SExpr e -> - let* _, rt1 = eval_expr rt e in - return (rt1, Normal) + let* _, rt1 = eval_expr rt e in + return (rt1, Normal) | SDecl (decl, init) -> - let id = ident_of_vardecl decl in - let* value, rt1 = - match init with None -> return (VNull, rt) | Some e -> eval_expr rt e - in - let loc, rt2 = alloc_r value rt1 in - let* env3 = add_var id loc rt2.env in - let env4 = - match init with Some _ -> mark_initialized id env3 | None -> env3 - in - let rt3 = { rt2 with env = env4 } in - return (rt3, Normal) - | SIf (cond, then_s, else_s) -> ( + let id = ident_of_vardecl decl in + let* value, rt1 = + match init with + | None -> return (VNull, rt) + | Some e -> eval_expr rt e + in + let loc, rt2 = alloc_r value rt1 in + let* env3 = add_var id loc rt2.env in + let env4 = + match init with + | Some _ -> mark_initialized id env3 + | None -> env3 + in + let rt3 = { rt2 with env = env4 } in + return (rt3, Normal) + | SIf (cond, then_s, else_s) -> + let* v, rt1 = eval_expr rt cond in + (match v with + | VBool true -> exec_stmt rt1 then_s + | VBool false -> + (match else_s with + | None -> return (rt1, Normal) + | Some s -> exec_stmt rt1 s) + | _ -> Error TypeMismatch) + | SWhile (cond, body) -> + let rec loop rt = let* v, rt1 = eval_expr rt cond in match v with - | VBool true -> exec_stmt rt1 then_s - | VBool false -> ( - match else_s with - | None -> return (rt1, Normal) - | Some s -> exec_stmt rt1 s) - | _ -> Error TypeMismatch) - | SWhile (cond, body) -> - let rec loop rt = - let* v, rt1 = eval_expr rt cond in - match v with - | VBool true -> ( - let* rt2, r = exec_stmt rt1 body in - match r with - | Normal -> loop rt2 - | Continue -> loop rt2 - | Break -> return (rt2, Normal) - | Return v -> return (rt2, Return v)) - | VBool false -> return (rt1, Normal) - | _ -> Error TypeMismatch - in - loop rt + | VBool true -> + let* rt2, r = exec_stmt rt1 body in + (match r with + | Normal -> loop rt2 + | Continue -> loop rt2 + | Break -> return (rt2, Normal) + | Return v -> return (rt2, Return v)) + | VBool false -> return (rt1, Normal) + | _ -> Error TypeMismatch + in + loop rt | SBlock stmts -> - let* env1 = push_scope rt.env in - let rt1 = { rt with env = env1 } in - let* rt2, flow = exec_block rt1 stmts in - let* env3 = pop_scope rt2.env in - let rt3 = { rt2 with env = env3 } in - return (rt3, flow) + let* env1 = push_scope rt.env in + let rt1 = { rt with env = env1 } in + let* rt2, flow = exec_block rt1 stmts in + let* env3 = pop_scope rt2.env in + let rt3 = { rt2 with env = env3 } in + return (rt3, flow) | SReturn None -> return (rt, Return VNull) | SReturn (Some e) -> - let* v, rt1 = eval_expr rt e in - return (rt1, Return v) + let* v, rt1 = eval_expr rt e in + return (rt1, Return v) | SBreak -> return (rt, Break) | SContinue -> return (rt, Continue) | SFor (init, cond, step, body) -> - let* env0 = push_scope rt.env in - let rt0 = { rt with env = env0 } in - let* rt1 = - match init with - | None -> return rt0 - | Some s -> ( - let* rt1, r = exec_stmt rt0 s in - match r with - | Normal -> return rt1 - | _ -> Error (OtherError "invalid control flow in for init")) + let* env0 = push_scope rt.env in + let rt0 = { rt with env = env0 } in + let* rt1 = + match init with + | None -> return rt0 + | Some s -> + let* rt1, r = exec_stmt rt0 s in + (match r with + | Normal -> return rt1 + | _ -> Error (OtherError "invalid control flow in for init")) + in + let rec loop rt = + let* cond_val, rt1 = + match cond with + | None -> return (VBool true, rt) + | Some e -> eval_expr rt e in - let rec loop rt = - let* cond_val, rt1 = - match cond with - | None -> return (VBool true, rt) - | Some e -> eval_expr rt e - in - match cond_val with - | VBool false -> return (rt1, Normal) - | VBool true -> ( - let* rt2, r = exec_stmt rt1 body in - match r with - | Return v -> return (rt2, Return v) - | Break -> return (rt2, Normal) - | Continue | Normal -> - let* rt3 = - match step with - | None -> return rt2 - | Some e -> - let* _, rt = eval_expr rt2 e in - return rt - in - loop rt3) - | _ -> Error TypeMismatch - in - let* rt2, flow = loop rt1 in - let* env3 = pop_scope rt2.env in - let rt3 = { rt2 with env = env3 } in - return (rt3, flow) + match cond_val with + | VBool false -> return (rt1, Normal) + | VBool true -> + let* rt2, r = exec_stmt rt1 body in + (match r with + | Return v -> return (rt2, Return v) + | Break -> return (rt2, Normal) + | Continue | Normal -> + let* rt3 = + match step with + | None -> return rt2 + | Some e -> + let* _, rt = eval_expr rt2 e in + return rt + in + loop rt3) + | _ -> Error TypeMismatch + in + let* rt2, flow = loop rt1 in + let* env3 = pop_scope rt2.env in + let rt3 = { rt2 with env = env3 } in + return (rt3, flow) and exec_block rt = function | [] -> return (rt, Normal) - | s :: rest -> ( - let* rt1, r = exec_stmt rt s in - match r with Normal -> exec_block rt1 rest | _ -> return (rt1, r)) + | s :: rest -> + let* rt1, r = exec_stmt rt s in + (match r with + | Normal -> exec_block rt1 rest + | _ -> return (rt1, r)) +;; let rec init_static_fields rt fields acc = match fields with | [] -> Ok (rt, List.rev acc) | (id, typ, init_opt) :: rest -> - let default_value = - match typ with - | TypeBase TypeInt -> VInt 0 - | TypeBase TypeBool -> VBool false - | TypeBase TypeChar -> VChar '\x00' - | TypeBase TypeString -> VString "" - | TypeVoid -> VNull - in - let rt_with_field = - { rt with static_fields = (id, default_value) :: rt.static_fields } - in - let* value, rt1 = - match init_opt with - | Some init_expr -> eval_expr rt_with_field init_expr - | None -> return (default_value, rt_with_field) - in - let rt2 = update_static_field id value rt1 in - init_static_fields rt2 rest ((id, value) :: acc) + let default_value = + match typ with + | TypeBase TypeInt -> VInt 0 + | TypeBase TypeBool -> VBool false + | TypeBase TypeChar -> VChar '\x00' + | TypeBase TypeString -> VString "" + | TypeVoid -> VNull + in + let rt_with_field = + { rt with static_fields = (id, default_value) :: rt.static_fields } + in + let* value, rt1 = + match init_opt with + | Some init_expr -> eval_expr rt_with_field init_expr + | None -> return (default_value, rt_with_field) + in + let rt2 = update_static_field id value rt1 in + init_static_fields rt2 rest ((id, value) :: acc) +;; let rec init_instance_fields rt fields acc = match fields with | [] -> Ok (rt, List.rev acc) | (id, typ, init_opt) :: rest -> - let* value, rt1 = - match init_opt with - | Some init_expr -> eval_expr rt init_expr - | None -> - let default = - match typ with - | TypeBase TypeInt -> VInt 0 - | TypeBase TypeBool -> VBool false - | TypeBase TypeChar -> VChar '\x00' - | TypeBase TypeString -> VString "" - | TypeVoid -> VNull - in - return (default, rt) - in - init_instance_fields rt1 rest ((id, value) :: acc) + let* value, rt1 = + match init_opt with + | Some init_expr -> eval_expr rt init_expr + | None -> + let default = + match typ with + | TypeBase TypeInt -> VInt 0 + | TypeBase TypeBool -> VBool false + | TypeBase TypeChar -> VChar '\x00' + | TypeBase TypeString -> VString "" + | TypeVoid -> VNull + in + return (default, rt) + in + init_instance_fields rt1 rest ((id, value) :: acc) +;; let init_program (Class (_, name, fields)) = let class_def = class_of_ast (Class ([], name, fields)) in let rt = { empty_runtime with class_def = Some class_def } in - let rt_with_methods = List.fold_left (fun rt (id, func) -> { rt with fenv = (id, func) :: rt.fenv }) - rt class_def.methods + rt + class_def.methods in - let static_fields = List.filter (fun (_, _, _, is_static) -> is_static) class_def.fields in let instance_fields = List.filter (fun (_, _, _, is_static) -> not is_static) class_def.fields in - - let strip_static (id, typ, init, _) = (id, typ, init) in + let strip_static (id, typ, init, _) = id, typ, init in let static_field_infos = List.map strip_static static_fields in let instance_field_infos = List.map strip_static instance_fields in - - let* rt1, static_vals = - init_static_fields rt_with_methods static_field_infos [] - in + let* rt1, static_vals = init_static_fields rt_with_methods static_field_infos [] in let rt2 = { rt1 with static_fields = static_vals } in - let* rt3, instance_vals = init_instance_fields rt2 instance_field_infos [] in - let obj_id = 0 in let program_object = { obj_id; fields = instance_vals } in - let rt4 = - { rt3 with objects = [ program_object ]; curr_object = Some obj_id } - in - + let rt4 = { rt3 with objects = [ program_object ]; curr_object = Some obj_id } in Ok (None, rt4) +;; let interpret_program prog = match prog with - | Program cls -> ( - match init_program cls with - | Ok (_, rt) -> ( - match rt.class_def with - | Some class_def -> ( - match - List.find_opt (fun (id, _) -> id = Id "Main") class_def.methods - with - | Some (_, main_func) -> - let* v, _ = call_function rt main_func [] in - Ok (Some v) - | None -> Error (OtherError "Main method not found")) - | None -> Error (OtherError "No class definition")) - | Error e -> Error e) + | Program cls -> + (match init_program cls with + | Ok (_, rt) -> + (match rt.class_def with + | Some class_def -> + (match List.find_opt (fun (id, _) -> id = Id "Main") class_def.methods with + | Some (_, main_func) -> + let* v, _ = call_function rt main_func [] in + Ok (Some v) + | None -> Error (OtherError "Main method not found")) + | None -> Error (OtherError "No class definition")) + | Error e -> Error e) +;; let interpret str = match apply_parser Parser.parse_prog str with | Ok prog -> interpret_program prog | Error e -> Error (OtherError e) +;; (* TODO: combine repeated code into functions? unwrap_return @@ -576,10 +632,10 @@ let interpret str = (* TODO: error messages? *) (* TODO: lambdas + closures - arrays (1D) + new - FIX BUGS (interpreter) - Quicktests for parser (if time permits) - pre/post increment/decrement - LINQ (simple array queries) - async/await (at least without lambdas) + arrays (1D) + new + FIX BUGS (interpreter) + Quicktests for parser (if time permits) + pre/post increment/decrement + LINQ (simple array queries) + async/await (at least without lambdas) *) diff --git a/CSharpStrange/lib/monads.ml b/CSharpStrange/lib/monads.ml index 69930bf8..3e437ce5 100644 --- a/CSharpStrange/lib/monads.ml +++ b/CSharpStrange/lib/monads.ml @@ -7,55 +7,59 @@ open Common module STATEERROR = struct type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t - let return : 'a -> ('st, 'a) t = fun x st -> (st, Result.Ok x) - let fail : 'a -> ('st, 'b) t = fun e st -> (st, Result.Error e) + let return : 'a -> ('st, 'a) t = fun x st -> st, Result.Ok x + let fail : 'a -> ('st, 'b) t = fun e st -> st, Result.Error e let ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t = - fun x f st -> + fun x f st -> let st, x = x st in - match x with Result.Ok x -> f x st | Result.Error e -> fail e st + match x with + | Result.Ok x -> f x st + | Result.Error e -> fail e st + ;; - let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = - fun x1 x2 -> x1 >>= fun _ -> x2 + let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = fun x1 x2 -> x1 >>= fun _ -> x2 let ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t = - fun x1 x2 st -> + fun x1 x2 st -> let st, x = x1 st in - match x with Result.Ok x -> return x st | Result.Error _ -> x2 st + match x with + | Result.Ok x -> return x st + | Result.Error _ -> x2 st + ;; let ( >>| ) : ('st, 'a) t -> ('a -> 'b) -> ('st, 'b) t = - fun x f st -> + fun x f st -> let st, x = x st in - match x with Result.Ok x -> return (f x) st | Result.Error e -> fail e st + match x with + | Result.Ok x -> return (f x) st + | Result.Error e -> fail e st + ;; let lift2 : ('a -> 'b -> 'c) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t = - fun f a b -> - a >>= fun r_a -> - b >>= fun r_b -> return @@ f r_a r_b - - let lift3 : - ('a -> 'b -> 'c -> 'd) -> - ('st, 'a) t -> - ('st, 'b) t -> - ('st, 'c) t -> - ('st, 'd) t = - fun f a b c -> lift2 f a b >>= fun f -> c >>| f + fun f a b -> a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b + ;; + + let lift3 + : ('a -> 'b -> 'c -> 'd) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t -> ('st, 'd) t + = + fun f a b c -> lift2 f a b >>= fun f -> c >>| f + ;; let read : ('st, 'st) t = fun st -> return st st - let write : 'st -> ('st, unit) t = fun new_st _ -> (new_st, Result.Ok ()) + let write : 'st -> ('st, unit) t = fun new_st _ -> new_st, Result.Ok () let map : ('a -> ('st, 'b) t) -> 'a list -> ('st, 'b list) t = - fun f list -> - let f acc el = - acc >>= fun acc -> - f el >>= fun el -> return (el :: acc) - in + fun f list -> + let f acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in List.fold_left f (return []) list >>| List.rev + ;; let iter : ('a -> ('st, unit) t) -> 'a list -> ('st, unit) t = - fun f list -> + fun f list -> let f acc elem = acc *> f elem *> return () in List.fold_left f (return ()) list + ;; let run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t = fun f st -> f st end @@ -70,50 +74,85 @@ module TYPECHECK = struct let return_with_fail = function | Some x -> return x | None -> fail (TCError OccursCheck) + ;; + + let read_local : 'a IdMap.t t = + read + >>= function + | _, l, _, _, _ -> return l + ;; - let read_local : 'a IdMap.t t = read >>= function _, l, _, _, _ -> return l let read_local_el id f = read_local >>= fun l -> IdMap.find_opt id l |> f let read_local_el_opt id = read_local_el id return let read_local_el id = read_local_el id return_with_fail let write_local n_l = - read >>= function g, _, n, m, main -> write (g, n_l, n, m, main) + read + >>= function + | g, _, n, m, main -> write (g, n_l, n, m, main) + ;; let write_local_el el_id el_ctx = read_local >>= fun l -> write_local (IdMap.add el_id el_ctx l) + ;; let write_meth_type_opt t = - read >>= function g, l, n, _, main -> write (g, l, n, t, main) + read + >>= function + | g, l, n, _, main -> write (g, l, n, t, main) + ;; let write_meth_type t = write_meth_type_opt (Some t) - let read_global : 'a IdMap.t t = read >>= function g, _, _, _, _ -> return g + + let read_global : 'a IdMap.t t = + read + >>= function + | g, _, _, _, _ -> return g + ;; + let read_global_el id f = read_global >>= fun g -> IdMap.find_opt id g |> f let read_global_el_opt id = read_global_el id return let read_global_el id = read_global_el id return_with_fail let read_meth_type : _type option t = - read >>= function _, _, _, m_t, _ -> return m_t + read + >>= function + | _, _, _, m_t, _ -> return m_t + ;; let read_main_class : class_with_main option t = - read >>= function _, _, _, _, main -> return main + read + >>= function + | _, _, _, _, main -> return main + ;; let write_main_class main = - read >>= function g, l, n, t, _ -> write (g, l, n, t, main) + read + >>= function + | g, l, n, t, _ -> write (g, l, n, t, main) + ;; let write_global n_g = - read >>= function _, l, n, m, main -> write (n_g, l, n, m, main) + read + >>= function + | _, l, n, m, main -> write (n_g, l, n, m, main) + ;; let write_global_el el_id el_ctx = read_global >>= fun g -> write_global (IdMap.add el_id el_ctx g) + ;; let get_curr_class_name : curr_class t = - read >>= function + read + >>= function | _, _, Some n, _, _ -> return n | _ -> - fail - (TCError - (ImpossibleResult "Current class can be 'none' only before running")) + fail (TCError (ImpossibleResult "Current class can be 'none' only before running")) + ;; let write_curr_class_name n = - read >>= function g, l, _, t, main -> write (g, l, Some n, t, main) + read + >>= function + | g, l, _, t, main -> write (g, l, Some n, t, main) + ;; end diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange/lib/parser.ml index 6158a502..73b9a628 100644 --- a/CSharpStrange/lib/parser.ml +++ b/CSharpStrange/lib/parser.ml @@ -10,47 +10,51 @@ open Base let chainl0 expr op = op >>= (fun op1 -> expr >>| op1) <|> expr let chainl1 expr op = - let rec pars e1 = - lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 - in + let rec pars e1 = lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 in expr >>= pars +;; let chainr1 expr op = - fix (fun x -> - lift2 (fun op1 -> op1) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) + fix (fun x -> lift2 (fun op1 -> op1) (lift2 (fun e1 op2 -> op2 e1) expr op) x <|> expr) +;; (* Special functions *) let reserved = - [ - "true"; - "false"; - "if"; - "else"; - "while"; - "public"; - "static"; - "void"; - "string"; - "char"; - "int"; - "bool"; - "for"; - "null"; - "new"; - "return"; - "break"; - "continue"; - "class"; - "async"; - "await"; + [ "true" + ; "false" + ; "if" + ; "else" + ; "while" + ; "public" + ; "static" + ; "void" + ; "string" + ; "char" + ; "int" + ; "bool" + ; "for" + ; "null" + ; "new" + ; "return" + ; "break" + ; "continue" + ; "class" + ; "async" + ; "await" ] +;; let in_reserved t = List.mem reserved t ~equal:String.equal -let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false + +let is_space = function + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false +;; let is_token_sym = function | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '_' -> true | _ -> false +;; let skip_spaces = skip_while is_space let parens p = skip_spaces *> char '(' *> p <* skip_spaces <* char ')' @@ -62,28 +66,32 @@ let skip_semicolons1 = skip_spaces *> char ';' *> skip_semicolons (* Values *) let parse_int = - take_while1 Char.is_digit >>= fun num -> - return @@ ValInt (Int.of_string num) <|> fail "Not an int" + take_while1 Char.is_digit + >>= fun num -> return @@ ValInt (Int.of_string num) <|> fail "Not an int" +;; let parse_char = char '\'' *> any_char <* char '\'' >>= (fun c -> return @@ ValChar c) <|> fail "Not a char" +;; let parse_bool = choice - [ - string "true" *> return (ValBool true); - string "false" *> return (ValBool false); - ] + [ string "true" *> return (ValBool true); string "false" *> return (ValBool false) ] <|> fail "Not a bool" +;; let parse_val_string = - char '\"' *> take_till (function '\"' -> true | _ -> false) + char '\"' + *> take_till (function + | '\"' -> true + | _ -> false) <* char '\"' >>= (fun s -> return @@ ValString s) <|> fail "Not a string" +;; let parse_null = string "null" *> return ValNull <|> fail "Not a null" @@ -92,53 +100,57 @@ let parse_null = string "null" *> return ValNull <|> fail "Not a null" let parse_modifiers = many (choice - [ - string "public" *> skip_spaces *> return MPublic; - string "static" *> skip_spaces *> return MStatic; - string "async" *> skip_spaces *> return MAsync; + [ string "public" *> skip_spaces *> return MPublic + ; string "static" *> skip_spaces *> return MStatic + ; string "async" *> skip_spaces *> return MAsync ]) +;; (* Type words *) let parse_type_word = - take_while is_token_sym >>= function + take_while is_token_sym + >>= function | "int" -> return TypeInt | "char" -> return TypeChar | "bool" -> return TypeBool | "string" -> return TypeString | _ -> fail "Wrong type word" +;; let parse_base_type = parse_type_word >>= fun tp -> return @@ TypeBase tp let val_to_expr p = skip_spaces *> p >>| fun x -> EValue x let parse_value = choice - [ - val_to_expr parse_bool; - val_to_expr parse_char; - val_to_expr parse_int; - val_to_expr parse_null; - val_to_expr parse_val_string; + [ val_to_expr parse_bool + ; val_to_expr parse_char + ; val_to_expr parse_int + ; val_to_expr parse_null + ; val_to_expr parse_val_string ] <|> fail "Value error" +;; let parse_id = - take_while1 is_token_sym >>= fun str -> - if String.is_empty str || in_reserved str || Char.is_digit str.[0] then - fail "Not an identifier" + take_while1 is_token_sym + >>= fun str -> + if String.is_empty str || in_reserved str || Char.is_digit str.[0] + then fail "Not an identifier" else return (Id str) +;; (* Expressions *) (* Variables && functions *) let parse_var_type = - choice ?failure_msg:(Some "Incorrect type") [ parse_base_type ] >>= fun x -> - return (TypeVar x) + choice ?failure_msg:(Some "Incorrect type") [ parse_base_type ] + >>= fun x -> return (TypeVar x) +;; let parse_var = - let parse_decl_id typ_ = - skip_spaces *> parse_id >>| fun id -> Var (typ_, id) - in + let parse_decl_id typ_ = skip_spaces *> parse_id >>| fun id -> Var (typ_, id) in skip_spaces *> parse_var_type >>= parse_decl_id +;; let parse_id_expr = skip_spaces *> (parse_id >>| fun x -> EId x) <* skip_spaces let parse_call_id = parse_id_expr @@ -146,9 +158,9 @@ let parse_args_list arg = parens @@ sep_by (skip_spaces *> char ',') arg let parse_call_args id (arg : expr t) = parse_args_list arg >>= fun args -> return @@ EFuncCall (id, Args args) +;; -let parse_call_expr (arg : expr t) = - parse_call_id >>= fun id -> parse_call_args id arg +let parse_call_expr (arg : expr t) = parse_call_id >>= fun id -> parse_call_args id arg (* Operations *) let parse_op op typ = skip_spaces *> string op *> return typ @@ -177,27 +189,26 @@ let ( ^!-^ ) = parse_un_op "-" OpNeg let parse_ops = fix (fun expr -> - let lv1 = - choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] - in - let lv2 = - many (choice [ ( ^!^ ); ( ^!-^ ) ]) >>= fun ops -> - lv1 >>= fun e -> - return (List.fold_right ops ~f:(fun op acc -> op acc) ~init:e) - in - (* TODO: rewrite somehow + more ops *) - let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in - let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in - let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in - let lv6 = chainl1 lv5 (choice [ ( ^==^ ); ( ^!=^ ) ]) in - let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in - let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in - chainr1 lv8 (choice [ ( ^=^ ) ])) + let lv1 = choice [ parens expr; parse_value; parse_call_expr expr; parse_id_expr ] in + let lv2 = + many (choice [ ( ^!^ ); ( ^!-^ ) ]) + >>= fun ops -> + lv1 >>= fun e -> return (List.fold_right ops ~f:(fun op acc -> op acc) ~init:e) + in + (* TODO: rewrite somehow + more ops *) + let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in + let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in + let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in + let lv6 = chainl1 lv5 (choice [ ( ^==^ ); ( ^!=^ ) ]) in + let lv7 = chainl1 lv6 (choice [ ( ^&&^ ) ]) in + let lv8 = chainl1 lv7 (choice [ ( ^||^ ) ]) in + chainr1 lv8 (choice [ ( ^=^ ) ])) <|> fail "Expr error" +;; let parse_assign = - lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops - <|> fail "Assign error" + lift3 (fun id eq ex -> eq id ex) parse_id_expr ( ^=^ ) parse_ops <|> fail "Assign error" +;; (* Statements *) @@ -208,26 +219,27 @@ let parse_decl = (fun dcl e -> SDecl (dcl, e)) parse_var (option None (skip_spaces *> char '=' *> parse_ops >>| fun e -> Some e)) +;; let expr_to_stmt expr = expr >>| fun x -> SExpr x - -let parse_stmt_ops = - expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] +let parse_stmt_ops = expr_to_stmt @@ choice [ parse_assign; parse_call_expr parse_ops ] let parse_if_else f_if_body = let parse_if_cond = string "if" *> skip_spaces *> parens parse_ops in let parse_else_cond ifls body = skip_spaces - *> (get_opt @@ (string "else" *> skip_spaces *> choice [ ifls; body ]) - <|> return None) + *> (get_opt @@ (string "else" *> skip_spaces *> choice [ ifls; body ]) <|> return None) in fix (fun ifls -> - let parse_body = f_if_body <|> (parse_stmt_ops <* skip_semicolons1) in - let parse_else_body = parse_else_cond ifls parse_body in - lift3 - (fun cond if_body else_body -> SIf (cond, if_body, else_body)) - parse_if_cond parse_body parse_else_body) + let parse_body = f_if_body <|> (parse_stmt_ops <* skip_semicolons1) in + let parse_else_body = parse_else_cond ifls parse_body in + lift3 + (fun cond if_body else_body -> SIf (cond, if_body, else_body)) + parse_if_cond + parse_body + parse_else_body) <|> fail "If error" +;; let parse_for body = let expr_to_option_stmt expr = get_opt @@ expr_to_stmt expr in @@ -241,21 +253,22 @@ let parse_for body = (fun (f_init_p, f_cond_p, f_iter_p) f_body -> SFor (f_init_p, f_cond_p, f_iter_p, f_body)) (parens - @@ lift3 - (fun init cond incr -> (init, cond, incr)) - (p_for_init <* skip_spaces <* char ';') - (p_for_expr <* skip_spaces <* char ';') - p_for_expr) + @@ lift3 + (fun init cond incr -> init, cond, incr) + (p_for_init <* skip_spaces <* char ';') + (p_for_expr <* skip_spaces <* char ';') + p_for_expr) p_body in string "for" *> p_for <|> fail "For error" +;; let parse_while body = let p_body = body <|> skip_semicolons1 *> parse_stmt_ops in let p_cond = parens parse_ops in let p_while = string "while" *> skip_spaces *> p_cond in - lift2 (fun cond body -> SWhile (cond, body)) p_while p_body - <|> fail "While error" + lift2 (fun cond body -> SWhile (cond, body)) p_while p_body <|> fail "While error" +;; let parse_return = lift2 @@ -263,49 +276,53 @@ let parse_return = (string "return") (parse_ops >>= (fun ret -> return (Some ret)) <|> return None) <|> fail "Return error" +;; -let parse_break = - skip_spaces *> string "break" *> return SBreak <|> fail "Break error" +let parse_break = skip_spaces *> string "break" *> return SBreak <|> fail "Break error" let parse_continue = skip_spaces *> string "continue" *> return SContinue <|> fail "Continue error" +;; let parse_block = fix (fun block -> - let sc p = p <* skip_semicolons1 in - (* операторы, которые должны заканчиваться ; *) - let op_sc p = p <* skip_semicolons in - - (* операторы, которые могут не заканчиваться ; *) - let body_step = - choice ?failure_msg:(Some "Error in some block sentence") - [ - sc parse_decl; - sc parse_break; - sc parse_continue; - sc parse_return; - sc parse_stmt_ops; - op_sc @@ parse_if_else block; - op_sc @@ parse_for block; - op_sc @@ parse_while block; - ] - in - braces (skip_semicolons *> many (skip_spaces *> body_step)) - >>= fun stmt_lst -> return @@ SBlock stmt_lst) + let sc p = p <* skip_semicolons1 in + (* операторы, которые должны заканчиваться ; *) + let op_sc p = p <* skip_semicolons in + (* операторы, которые могут не заканчиваться ; *) + let body_step = + choice + ?failure_msg:(Some "Error in some block sentence") + [ sc parse_decl + ; sc parse_break + ; sc parse_continue + ; sc parse_return + ; sc parse_stmt_ops + ; op_sc @@ parse_if_else block + ; op_sc @@ parse_for block + ; op_sc @@ parse_while block + ] + in + braces (skip_semicolons *> many (skip_spaces *> body_step)) + >>= fun stmt_lst -> return @@ SBlock stmt_lst) +;; (* Program class functions *) let parse_field_sign = let f_value = skip_spaces *> char '=' *> get_opt parse_ops in lift4 - (fun f_modif f_type f_id f_val -> (f_modif, f_type, f_id, f_val)) + (fun f_modif f_type f_id f_val -> f_modif, f_type, f_id, f_val) (skip_spaces *> parse_modifiers) (skip_spaces *> parse_var_type) - (skip_spaces *> parse_id) (option None f_value) + (skip_spaces *> parse_id) + (option None f_value) <* skip_semicolons1 +;; let parse_method_type = let parse_void = string "void" *> return TypeVoid in choice ?failure_msg:(Some "Not a method type") [ parse_base_type; parse_void ] +;; let parse_method_sign = let parse_args = @@ -313,46 +330,53 @@ let parse_method_sign = >>= fun exp -> return (Params exp) in lift4 - (fun m_modif m_type m_id m_params -> (m_modif, m_type, m_id, m_params)) + (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) (skip_spaces *> parse_modifiers) (skip_spaces *> parse_method_type) (skip_spaces *> parse_id) (skip_spaces *> parse_args) +;; let parse_method_member = lift2 (fun (mds, tp, id, ps) bd -> Method (mds, tp, id, ps, bd)) - parse_method_sign parse_block + parse_method_sign + parse_block +;; let parse_field_member = - parse_field_sign >>| function - | mds, tp, id, Some ex -> - VarField (mds, tp, id, Some (EBinOp (OpAssign, EId id, ex))) + parse_field_sign + >>| function + | mds, tp, id, Some ex -> VarField (mds, tp, id, Some (EBinOp (OpAssign, EId id, ex))) | mds, tp, id, None -> VarField (mds, tp, id, None) +;; let parse_class_members = let member = - choice ?failure_msg:(Some "Method error") - [ parse_method_member; parse_field_member ] + choice ?failure_msg:(Some "Method error") [ parse_method_member; parse_field_member ] in braces @@ sep_by skip_spaces member +;; let parse_class = let class_id = - skip_spaces *> string "class" *> skip_spaces *> parse_id - <|> fail "Class sign error" + skip_spaces *> string "class" *> skip_spaces *> parse_id <|> fail "Class sign error" in lift3 (fun cl_mdf cl_id cl_mbs -> Class (cl_mdf, cl_id, cl_mbs)) (skip_spaces *> parse_modifiers) - class_id parse_class_members + class_id + parse_class_members +;; -let parse_prog : program t = - parse_class <* skip_spaces >>| fun prog -> Program prog +let parse_prog : program t = parse_class <* skip_spaces >>| fun prog -> Program prog (* Main functions *) let apply_parser parser = parse_string ~consume:Consume.All parser let parse_option p str = - match apply_parser p str with Ok x -> Some x | Error _ -> None + match apply_parser p str with + | Ok x -> Some x + | Error _ -> None +;; diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange/lib/prettyprinter.ml index bb441fc1..58fcfab9 100644 --- a/CSharpStrange/lib/prettyprinter.ml +++ b/CSharpStrange/lib/prettyprinter.ml @@ -80,8 +80,7 @@ let rec pp_expr fmt = function | EUnOp (op, e) -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e | EId id -> pp_ident fmt id | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 - | EFuncCall (e, Args args) -> - fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args + | EFuncCall (e, Args args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args | EAwait e -> fprintf fmt "await %a" pp_expr e ;; diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange/lib/typecheck.ml index 13aeae51..54e42d94 100644 --- a/CSharpStrange/lib/typecheck.ml +++ b/CSharpStrange/lib/typecheck.ml @@ -12,67 +12,94 @@ let value_to_type = function | ValBool _ -> TypeBase TypeBool | ValString _ -> TypeBase TypeString | ValNull -> TypeBase TypeInt (* TODO separately? *) +;; let string_of_ident (Id s) = s -let vartype_to_type = function TypeVar t -> t -let vardecl_to_type = function Var (t, _) -> return (vartype_to_type t) + +let vartype_to_type = function + | TypeVar t -> t +;; + +let vardecl_to_type = function + | Var (t, _) -> return (vartype_to_type t) +;; + let name_to_obj_ctx n = read_local_el n let eq f e1 e2 = - match f e1 e2 with true -> return e1 | false -> fail (TCError TypeMismatch) + match f e1 e2 with + | true -> return e1 + | false -> fail (TCError TypeMismatch) +;; let eq_type t1 t2 = eq equal__type t1 t2 let eq_ident n1 n2 = eq equal_ident n1 n2 let eq_ident_return_ctx n1 n2 m f = - match equal_ident n1 n2 with true -> Some (f m) | false -> None + match equal_ident n1 n2 with + | true -> Some (f m) + | false -> None +;; let field_of_ast = function | VarField (mods, typ, id, init) -> - let is_static = - List.exists (function MStatic -> true | _ -> false) mods - in - { - field_modifiers = mods; - field_type = typ; - field_name = id; - field_init = init; - is_static; - } + let is_static = + List.exists + (function + | MStatic -> true + | _ -> false) + mods + in + { field_modifiers = mods + ; field_type = typ + ; field_name = id + ; field_init = init + ; is_static + } | Method _ -> failwith "Expected field, got method" +;; let method_of_ast = function | Ast.Method (mods, ret_type, id, pms, body) -> - let is_static = - List.exists (function MStatic -> true | _ -> false) mods - in - let is_main = equal_ident id (Id "Main") in - { - method_modifiers = mods; - method_return = ret_type; - method_name = id; - method_params = pms; - method_body = body; - is_static; - is_main; - } + let is_static = + List.exists + (function + | MStatic -> true + | _ -> false) + mods + in + let is_main = equal_ident id (Id "Main") in + { method_modifiers = mods + ; method_return = ret_type + ; method_name = id + ; method_params = pms + ; method_body = body + ; is_static + ; is_main + } | Ast.VarField _ -> failwith "Expected method, got field" +;; let get_class_memb id memb = match memb with | VarField (_, _, f_id, _) when equal_ident f_id id -> - Some (TCField (field_of_ast memb)) + Some (TCField (field_of_ast memb)) | Method (_, _, m_id, _, _) when equal_ident m_id id -> - Some (TCMethod (method_of_ast memb)) + Some (TCMethod (method_of_ast memb)) | _ -> None +;; -let get_class_name = function Class (_, id, _) -> id +let get_class_name = function + | Class (_, id, _) -> id +;; let find_memb_from_obj obj_id id = let find_memb b id f = List.find_map (f id) b in let find_class_memb b id = find_memb b id get_class_memb in - read_global_el obj_id >>= function + read_global_el obj_id + >>= function | TCClass (Class (_, _, b)) -> find_class_memb b id |> return +;; let is_public obj_id ctx mds = let rec is_m_list_public = function @@ -80,50 +107,53 @@ let is_public obj_id ctx mds = | MPublic :: _ -> return (Some ctx) | _ :: xs -> is_m_list_public xs in - is_m_list_public mds - <|> (read_global_el obj_id >>= fun _ -> fail (TCError AccessError)) + is_m_list_public mds <|> (read_global_el obj_id >>= fun _ -> fail (TCError AccessError)) +;; let find_obj_memb_with_fail n_obj n_mem = - find_memb_from_obj n_obj n_mem >>= function - | Some memb -> ( - match memb with - | TCField f -> is_public n_obj memb f.field_modifiers - | TCMethod m -> is_public n_obj memb m.method_modifiers - | _ -> - fail - (TCError - (ImpossibleResult "Object can only have fields and methods"))) + find_memb_from_obj n_obj n_mem + >>= function + | Some memb -> + (match memb with + | TCField f -> is_public n_obj memb f.field_modifiers + | TCMethod m -> is_public n_obj memb m.method_modifiers + | _ -> fail (TCError (ImpossibleResult "Object can only have fields and methods"))) | None -> fail (TCError (OtherError "Class member not found")) +;; let find_memb_type = function | TCLocalVar v -> return (vartype_to_type v.var_type) | TCField f -> return (vartype_to_type f.field_type) | TCMethod m -> return m.method_return +;; let typecheck_method_args (Params params) (Args args) expr_tc = let params_to_list_of_type p = - List.map (function Var (t, _) -> vartype_to_type t) p - in - let args_to_list_of_type a = - map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a + List.map + (function + | Var (t, _) -> vartype_to_type t) + p in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with - | 0 -> ( - match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + | 0 -> + (match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) | _ -> fail (TCError (OtherError "Method invocation check error")) in - args_to_list_of_type args >>= fun args -> + args_to_list_of_type args + >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params +;; let find_expr_type e expr_tc = expr_tc e >>= fun e -> find_memb_type e let typecheck_bin_op b e1 e2 expr_tc = let compare_two_expr_type e1 e2 = - find_expr_type e1 expr_tc >>= fun e1 -> - find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 + find_expr_type e1 expr_tc + >>= fun e1 -> find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 in let compare_three_expr_type e1 e2 t = compare_two_expr_type e1 e2 >>= fun e -> eq_type e t @@ -134,108 +164,109 @@ let typecheck_bin_op b e1 e2 expr_tc = in match b with | OpAdd | OpMul | OpSub | OpDiv | OpMod -> - compare_three_expr_type e1 e2 (TypeBase TypeInt) - *> return_rez (TypeBase TypeInt) + compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeInt) | OpLess | OpLessEqual | OpMore | OpMoreEqual -> - compare_three_expr_type e1 e2 (TypeBase TypeInt) - *> return_rez (TypeBase TypeBool) - | OpEqual | OpNonEqual -> - compare_two_expr_type e1 e2 *> return_rez (TypeBase TypeBool) + compare_three_expr_type e1 e2 (TypeBase TypeInt) *> return_rez (TypeBase TypeBool) + | OpEqual | OpNonEqual -> compare_two_expr_type e1 e2 *> return_rez (TypeBase TypeBool) | OpAnd | OpOr -> - compare_three_expr_type e1 e2 (TypeBase TypeBool) - *> return_rez (TypeBase TypeBool) + compare_three_expr_type e1 e2 (TypeBase TypeBool) *> return_rez (TypeBase TypeBool) | OpAssign -> - find_expr_type e1 expr_tc >>= fun e -> - compare_two_expr_type e1 e2 *> return_rez e + find_expr_type e1 expr_tc >>= fun e -> compare_two_expr_type e1 e2 *> return_rez e +;; let typecheck_un_op u e expr_tc = let tc_un_op u e = - find_expr_type e expr_tc >>= fun t -> + find_expr_type e expr_tc + >>= fun t -> match u with | OpNot -> eq_type t (TypeBase TypeBool) | OpNeg -> eq_type t (TypeBase TypeInt) in - tc_un_op u e >>= fun t -> + tc_un_op u e + >>= fun t -> let var_info = { var_type = TypeVar t; initialized = true } in return (TCLocalVar var_info) +;; let tc_method_args (Params params) (Args args) expr_tc = let params_to_list_of_type p = - List.map (function Var (t, _) -> vartype_to_type t) p - in - let args_to_list_of_type a = - map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a + List.map + (function + | Var (t, _) -> vartype_to_type t) + p in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with - | 0 -> ( - match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + | 0 -> + (match List.equal eq l1 l2 with + | true -> return rez + | false -> fail (TCError (OtherError "Method invocation check error"))) | _ -> fail (TCError (OtherError "Method invocation check error")) in - args_to_list_of_type args >>= fun args -> + args_to_list_of_type args + >>= fun args -> compare_two_lists (params_to_list_of_type params) args equal__type params +;; let tc_method_invoke e args expr_tc = - expr_tc e >>= function - | TCMethod m -> ( - tc_method_args m.method_params args expr_tc >>= fun _ -> - match m.method_return with - | TypeBase t -> - let var_info = - { var_type = TypeVar (TypeBase t); initialized = true } - in - return (TCLocalVar var_info) - | TypeVoid -> - fail - (TCError (OtherError "Void methods cannot be used in expressions"))) + expr_tc e + >>= function + | TCMethod m -> + tc_method_args m.method_params args expr_tc + >>= fun _ -> + (match m.method_return with + | TypeBase t -> + let var_info = { var_type = TypeVar (TypeBase t); initialized = true } in + return (TCLocalVar var_info) + | TypeVoid -> + fail (TCError (OtherError "Void methods cannot be used in expressions"))) | TCField _ -> fail (TCError (OtherError "Cannot call a field as a method")) - | TCLocalVar _ -> - fail (TCError (OtherError "Cannot call a variable as a method")) + | TCLocalVar _ -> fail (TCError (OtherError "Cannot call a variable as a method")) +;; let check_initialized n = (* TODO: refactor to locals ?? *) - read_local_el n >>= function + read_local_el n + >>= function | TCLocalVar v when v.initialized -> return () | TCLocalVar _ -> fail (TCError (OtherError "Variable may be uninitialized")) | TCField _ -> return () | TCMethod _ -> return () +;; let typecheck_expr = let rec tc_expr_ = function | EId n -> - name_to_obj_ctx n - >>= (fun ctx -> check_initialized n *> return ctx) - <|> ( get_curr_class_name >>= fun class_name -> - find_memb_from_obj class_name n >>= function - | Some memb -> return memb - | None -> - fail - (TCError - (OtherError ("Variable not found: " ^ string_of_ident n))) - ) + name_to_obj_ctx n + >>= (fun ctx -> check_initialized n *> return ctx) + <|> (get_curr_class_name + >>= fun class_name -> + find_memb_from_obj class_name n + >>= function + | Some memb -> return memb + | None -> + fail (TCError (OtherError ("Variable not found: " ^ string_of_ident n)))) | EValue v -> - let var_info = - { var_type = TypeVar (value_to_type v); initialized = true } - in - return (TCLocalVar var_info) + let var_info = { var_type = TypeVar (value_to_type v); initialized = true } in + return (TCLocalVar var_info) | EFuncCall (e, args) -> tc_method_invoke e args tc_expr_ | EBinOp (b, e1, e2) -> typecheck_bin_op b e1 e2 tc_expr_ | EUnOp (u, e) -> typecheck_un_op u e tc_expr_ | _ -> fail (TCError NotImplemented) in tc_expr_ +;; let typecheck_expr_with_type e = typecheck_expr e >>= fun x -> find_memb_type x - -let eq_type_with_expr t e = - typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t +let eq_type_with_expr t e = typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t let save_decl n ctx = - read_local_el_opt n >>= function + read_local_el_opt n + >>= function | None -> write_local_el n ctx | Some _ -> fail (TCError (OtherError "This variable is already declared")) +;; let apply_local f = read_local >>= fun old_l -> f *> write_local old_l @@ -245,20 +276,22 @@ let rec typecheck_stmt = in let typecheck_stmt_expr expr = match expr with - | EFuncCall (e, args) -> ( - typecheck_expr e >>= function - | TCMethod { method_return = TypeVoid; method_params = pms; _ } -> - typecheck_method_args pms args typecheck_expr *> return () - | TCMethod _ -> fail (TCError TypeMismatch) - | _ -> fail (TCError TypeMismatch)) + | EFuncCall (e, args) -> + typecheck_expr e + >>= (function + | TCMethod { method_return = TypeVoid; method_params = pms; _ } -> + typecheck_method_args pms args typecheck_expr *> return () + | TCMethod _ -> fail (TCError TypeMismatch) + | _ -> fail (TCError TypeMismatch)) | EBinOp (OpAssign, _, _) -> typecheck_expr expr *> return () | _ -> fail (TCError TypeMismatch) in let save_decl n t initialized = - read_local_el_opt n >>= function + read_local_el_opt n + >>= function | None -> - let var_info = { var_type = TypeVar t; initialized } in - write_local_el n (TCLocalVar var_info) + let var_info = { var_type = TypeVar t; initialized } in + write_local_el n (TCLocalVar var_info) | Some _ -> fail (TCError (OtherError "This variable is already declared")) in let typecheck_decl t n init_expr = @@ -267,16 +300,14 @@ let rec typecheck_stmt = | None -> save_decl n t false *> return () in let typecheck_return e_opt = - read_meth_type >>= fun m_t -> - match (m_t, e_opt) with + read_meth_type + >>= fun m_t -> + match m_t, e_opt with | Some TypeVoid, None -> return () | Some (TypeBase t), Some e -> - (eq_type_with_expr (TypeBase t) e - <|> fail - (TCError - (OtherError "Returned type does not match the function type")) - ) - *> return () + (eq_type_with_expr (TypeBase t) e + <|> fail (TCError (OtherError "Returned type does not match the function type"))) + *> return () | _ -> fail (TCError TypeMismatch) in let opt_unpack f = function @@ -295,7 +326,10 @@ let rec typecheck_stmt = in let typecheck_if_state cond b s_opt tc_st = let typecheck_cond = is_expr_bool cond in - let typecheck_state = function Some st -> tc_st st | None -> return () in + let typecheck_state = function + | Some st -> tc_st st + | None -> return () + in lift3 (fun _ _ _ -> ()) typecheck_cond (tc_st b) (typecheck_state s_opt) in function @@ -304,11 +338,11 @@ let rec typecheck_stmt = | SReturn e -> typecheck_return e | SWhile (e, s) -> apply_local (is_expr_bool e *> typecheck_stmt s) | SFor (init, cond, iter, b) -> - apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) - | SIf (e, b, s_opt) -> - apply_local (typecheck_if_state e b s_opt typecheck_stmt) + apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) + | SIf (e, b, s_opt) -> apply_local (typecheck_if_state e b s_opt typecheck_stmt) | SBlock st_l -> apply_local (iter typecheck_stmt st_l) | SBreak | SContinue -> fail (TCError NotImplemented) +;; let tc_member mem class_fields = let tc_class_field f_type = function @@ -318,8 +352,8 @@ let tc_member mem class_fields = let save_params_to_l (Params params) = let f = function | Var (t, n) -> - let var_info = { var_type = t; initialized = true } in - write_local_el n (TCLocalVar var_info) + let var_info = { var_type = t; initialized = true } in + write_local_el n (TCLocalVar var_info) in iter f params in @@ -327,71 +361,72 @@ let tc_member mem class_fields = apply_local (let add_field_to_env = function | VarField (mods, field_typ, id, init) -> - let field_info = - { - field_modifiers = mods; - field_type = field_typ; - field_name = id; - field_init = init; - is_static = false; - } - in - write_local_el id (TCField field_info) + let field_info = + { field_modifiers = mods + ; field_type = field_typ + ; field_name = id + ; field_init = init + ; is_static = false + } + in + write_local_el id (TCField field_info) | Method _ -> return () in iter add_field_to_env class_fields - *> write_meth_type typ *> save_params_to_l params *> typecheck_stmt body) + *> write_meth_type typ + *> save_params_to_l params + *> typecheck_stmt body) in let tc_class_method (mds, tp, id, pms, b) class_fields = let m = method_of_ast (Method (mds, tp, id, pms, b)) in - if m.is_main then - match (mds, pms, tp) with - | [ MStatic ], Params [], TypeBase TypeInt - | [ MStatic ], Params [], TypeVoid -> ( - tc_meth tp (Params []) b class_fields *> read_main_class >>= function - | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) - | Some _ -> fail (TCError (OtherError "Main method already exists"))) + if m.is_main + then ( + match mds, pms, tp with + | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> + tc_meth tp (Params []) b class_fields *> read_main_class + >>= (function + | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) + | Some _ -> fail (TCError (OtherError "Main method already exists"))) | _, _, _ -> - fail - (TCError - (OtherError - "Main must be static, non-async, no params, return int/void")) + fail + (TCError + (OtherError "Main must be static, non-async, no params, return int/void"))) else tc_meth tp pms b class_fields in match mem with | VarField (_, tp, _, e_opt) -> tc_class_field tp e_opt - | Method (mds, tp, id, pms, b) -> - tc_class_method (mds, tp, id, pms, b) class_fields + | Method (mds, tp, id, pms, b) -> tc_class_method (mds, tp, id, pms, b) class_fields +;; let save_global id ctx = - read_global_el_opt id >>= function + read_global_el_opt id + >>= function | None -> write_global_el id ctx | Some _ -> fail (TCError (OtherError "This variable is already declared")) +;; let typecheck_obj cl = match cl with | Class (mds, id, fields) -> - let write_mems () = - let f mem = - match mem with - | VarField (_, _, id, _) -> - let field_info = field_of_ast mem in - save_decl id (TCField field_info) - | Method (_, _, id, _, _) -> - let method_info = method_of_ast mem in - save_decl id (TCMethod method_info) - in - iter f fields + let write_mems () = + let f mem = + match mem with + | VarField (_, _, id, _) -> + let field_info = field_of_ast mem in + save_decl id (TCField field_info) + | Method (_, _, id, _, _) -> + let method_info = method_of_ast mem in + save_decl id (TCMethod method_info) in - let tc_member_with_fields mem = tc_member mem fields in - let tc_mems = iter tc_member_with_fields fields in - let save_class = save_global id (TCClass cl) in - write_curr_class_name id - *> apply_local (write_mems () *> save_class *> tc_mems) - *> return () - -let typecheck prog = - run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) - -let typecheck_main prog = - typecheck prog |> fun ((_, _, _, _, main), res) -> (main, res) + iter f fields + in + let tc_member_with_fields mem = tc_member mem fields in + let tc_mems = iter tc_member_with_fields fields in + let save_class = save_global id (TCClass cl) in + write_curr_class_name id + *> apply_local (write_mems () *> save_class *> tc_mems) + *> return () +;; + +let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) +let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res diff --git a/CSharpStrange/tests/interpret_tests.ml b/CSharpStrange/tests/interpret_tests.ml index 60677a87..12973420 100644 --- a/CSharpStrange/tests/interpret_tests.ml +++ b/CSharpStrange/tests/interpret_tests.ml @@ -7,11 +7,13 @@ open C_sharp_strange_lib.Monads let show_wrap str = match interpret str with - | Result.Ok x -> ( - match x with - | Some x -> Format.printf "Result: '%a'" pp_value x - | None -> Format.print_string "Result: void\n") + | Result.Ok x -> + (match x with + | Some x -> Format.printf "Result: '%a'" pp_value x + | None -> Format.print_string "Result: void\n") | Result.Error er -> Format.printf "%a\n%!" pp_error (IError er) +;; + (* TODO: incluede TC? *) let%expect_test "Main 1" = @@ -36,10 +38,11 @@ let%expect_test "Main 1" = } |}; [%expect {| Result: '-58' |}] +;; (* TODO: Доступ к нестатическим полям из статического метода запрещен - В статическом классе только статические методы, но static не может быть входом в программу - Мб сделать проверку на класс внутри main, но не успею + В статическом классе только статические методы, но static не может быть входом в программу + Мб сделать проверку на класс внутри main, но не успею *) let%expect_test "Main 2" = @@ -59,6 +62,8 @@ let%expect_test "Main 2" = } |}; [%expect {| Result: '870' |}] +;; + (* TODO: n without static *) let%expect_test "Main 3" = @@ -90,6 +95,7 @@ let%expect_test "Main 3" = } |}; [%expect {| Result: '141' |}] +;; let%expect_test "Main 4" = show_wrap @@ -107,6 +113,7 @@ let%expect_test "Main 4" = } |}; [%expect {| Result: '18' |}] +;; let%expect_test "Functions 1" = show_wrap @@ -127,6 +134,8 @@ let%expect_test "Functions 1" = } |}; [%expect {| Result: '1' |}] +;; + (* TODO: не static нельзя *) let%expect_test "Invalid value" = @@ -141,3 +150,4 @@ let%expect_test "Invalid value" = } |}; [%expect {| (IError (OtherError "Value is not initialized"))|}] +;; diff --git a/CSharpStrange/tests/interpret_tests.mli b/CSharpStrange/tests/interpret_tests.mli index 71f70320..2a5ede90 100644 --- a/CSharpStrange/tests/interpret_tests.mli +++ b/CSharpStrange/tests/interpret_tests.mli @@ -1,3 +1,3 @@ (** Copyright 2025, Dmitrii Kuznetsov *) -(** SPDX-License-Identifier: LGPL-3.0-or-later *) \ No newline at end of file +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange/tests/parser_tests.ml index 58d458a6..ed185e7d 100644 --- a/CSharpStrange/tests/parser_tests.ml +++ b/CSharpStrange/tests/parser_tests.ml @@ -12,163 +12,149 @@ let%test "Parse false" = apply_parser parse_bool {|false|} = Ok (ValBool false) let%test "Parse string" = apply_parser parse_val_string {|"sample"|} = Ok (ValString "sample") +;; -let%test "Parse parens" = - apply_parser (parens parse_int) {|(1)|} = Ok (ValInt 1) - -let%test "Parse braces" = - apply_parser (braces parse_int) {|{1}|} = Ok (ValInt 1) - -let%test "Parse brackets" = - apply_parser (brackets parse_int) {|[1]|} = Ok (ValInt 1) - -let%test "Parse one modifier 1" = - apply_parser parse_modifiers {|static|} = Ok [ MStatic ] - -let%test "Parse one modifier 2" = - apply_parser parse_modifiers {|public|} = Ok [ MPublic ] +let%test "Parse parens" = apply_parser (parens parse_int) {|(1)|} = Ok (ValInt 1) +let%test "Parse braces" = apply_parser (braces parse_int) {|{1}|} = Ok (ValInt 1) +let%test "Parse brackets" = apply_parser (brackets parse_int) {|[1]|} = Ok (ValInt 1) +let%test "Parse one modifier 1" = apply_parser parse_modifiers {|static|} = Ok [ MStatic ] +let%test "Parse one modifier 2" = apply_parser parse_modifiers {|public|} = Ok [ MPublic ] let%test "Parse two modifiers" = apply_parser parse_modifiers {|public async|} = Ok [ MPublic; MAsync ] +;; let%test "Parse add 1" = apply_parser parse_ops {| 1 + 2|} = Ok (EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2))) +;; let%test "Parse add 2" = - apply_parser parse_ops {| a + b|} - = Ok (EBinOp (OpAdd, EId (Id "a"), EId (Id "b"))) + apply_parser parse_ops {| a + b|} = Ok (EBinOp (OpAdd, EId (Id "a"), EId (Id "b"))) +;; let%test "Parse many adds" = apply_parser parse_ops {| 1 + 2 + 3|} = Ok (EBinOp - ( OpAdd, - EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), - EValue (ValInt 3) )) + (OpAdd, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; let%test "Parse adds with mul 1" = apply_parser parse_ops {|1 + 2 * 3|} = Ok (EBinOp - ( OpAdd, - EValue (ValInt 1), - EBinOp (OpMul, EValue (ValInt 2), EValue (ValInt 3)) )) + (OpAdd, EValue (ValInt 1), EBinOp (OpMul, EValue (ValInt 2), EValue (ValInt 3)))) +;; let%test "Parse adds with mul 2" = apply_parser parse_ops {| (1 + 2 ) * 3|} = Ok (EBinOp - ( OpMul, - EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), - EValue (ValInt 3) )) + (OpMul, EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; let%test "Parse div with mod" = apply_parser parse_ops {| 1 / 2 % 3|} = Ok (EBinOp - ( OpMod, - EBinOp (OpDiv, EValue (ValInt 1), EValue (ValInt 2)), - EValue (ValInt 3) )) + (OpMod, EBinOp (OpDiv, EValue (ValInt 1), EValue (ValInt 2)), EValue (ValInt 3))) +;; let%test "Parse div with mod" = apply_parser parse_ops {| 1 - 2 / 3 + 4|} = Ok (EBinOp - ( OpAdd, - EBinOp - ( OpSub, - EValue (ValInt 1), - EBinOp (OpDiv, EValue (ValInt 2), EValue (ValInt 3)) ), - EValue (ValInt 4) )) + ( OpAdd + , EBinOp + ( OpSub + , EValue (ValInt 1) + , EBinOp (OpDiv, EValue (ValInt 2), EValue (ValInt 3)) ) + , EValue (ValInt 4) )) +;; let%test "Parse simple boolean expression" = apply_parser parse_ops {| ( 1 + 2 == 3 + 4 )|} = Ok (EBinOp - ( OpEqual, - EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), - EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) )) + ( OpEqual + , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) + , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) )) +;; let%test "Parse complex boolean expression" = apply_parser parse_ops {|( 1 + 2 < 3 + 4) && (5 == 8)|} = Ok (EBinOp - ( OpAnd, - EBinOp - ( OpLess, - EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)), - EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) ), - EBinOp (OpEqual, EValue (ValInt 5), EValue (ValInt 8)) )) + ( OpAnd + , EBinOp + ( OpLess + , EBinOp (OpAdd, EValue (ValInt 1), EValue (ValInt 2)) + , EBinOp (OpAdd, EValue (ValInt 3), EValue (ValInt 4)) ) + , EBinOp (OpEqual, EValue (ValInt 5), EValue (ValInt 8)) )) +;; let%test "Parse ident expr" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) - -let%test "Parse id in expressions 1" = - apply_parser parse_ops {| x|} = Ok (EId (Id "x")) +let%test "Parse id in expressions 1" = apply_parser parse_ops {| x|} = Ok (EId (Id "x")) let%test "Parse id in expressions 2" = - apply_parser parse_ops {|x + 1|} - = Ok (EBinOp (OpAdd, EId (Id "x"), EValue (ValInt 1))) + apply_parser parse_ops {|x + 1|} = Ok (EBinOp (OpAdd, EId (Id "x"), EValue (ValInt 1))) +;; let%test "Parse var declaration 1" = apply_parser parse_decl {|int x|} = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), None)) +;; let%test "Parse var declaration 2" = apply_parser parse_decl {|int x = 1|} - = Ok - (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1)))) + = Ok (SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1)))) +;; let%test "Parse multiple var declarations" = apply_parser parse_decl {|int x = y = z = 1|} = Ok (SDecl - ( Var (TypeVar (TypeBase TypeInt), Id "x"), - Some + ( Var (TypeVar (TypeBase TypeInt), Id "x") + , Some (EBinOp - ( OpAssign, - EId (Id "y"), - EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) + ( OpAssign + , EId (Id "y") + , EBinOp (OpAssign, EId (Id "z"), EValue (ValInt 1)) )) )) +;; let%test "Parse return 1" = - apply_parser parse_return {|return 5|} - = Ok (SReturn (Some (EValue (ValInt 5)))) - -let%test "Parse return 2" = - apply_parser parse_return {|return|} = Ok (SReturn None) + apply_parser parse_return {|return 5|} = Ok (SReturn (Some (EValue (ValInt 5)))) +;; +let%test "Parse return 2" = apply_parser parse_return {|return|} = Ok (SReturn None) let%test "Parse break" = apply_parser parse_break {|break|} = Ok SBreak - -let%test "Parse continue" = - apply_parser parse_continue {|continue|} = Ok SContinue - -let%test "Parse empty block 1" = - apply_parser parse_block {|{}|} = Ok (SBlock []) - -let%test "Parse empty block 2" = - apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) +let%test "Parse continue" = apply_parser parse_continue {|continue|} = Ok SContinue +let%test "Parse empty block 1" = apply_parser parse_block {|{}|} = Ok (SBlock []) +let%test "Parse empty block 2" = apply_parser parse_block {|{;;;;}|} = Ok (SBlock []) let%test "Parse block 1" = apply_parser parse_block {|{return 5;}|} = Ok (SBlock [ SReturn (Some (EValue (ValInt 5))) ]) +;; let%test "Parse block 2" = apply_parser parse_block {|{int x = 6; x = 6 + 1; return x;}|} = Ok (SBlock - [ - SDecl - (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 6))); - SExpr + [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 6))) + ; SExpr (EBinOp - ( OpAssign, - EId (Id "x"), - EBinOp (OpAdd, EValue (ValInt 6), EValue (ValInt 1)) )); - SReturn (Some (EId (Id "x"))); + ( OpAssign + , EId (Id "x") + , EBinOp (OpAdd, EValue (ValInt 6), EValue (ValInt 1)) )) + ; SReturn (Some (EId (Id "x"))) ]) +;; let%test "Parse while" = - apply_parser parse_block + apply_parser + parse_block {| { int x = 1; @@ -181,21 +167,20 @@ let%test "Parse while" = }|} = Ok (SBlock - [ - SDecl - (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1))); - SWhile - ( EBinOp (OpLess, EId (Id "x"), EValue (ValInt 1)), - SBlock - [ - SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))); - SBreak; - SContinue; - ] ); + [ SDecl (Var (TypeVar (TypeBase TypeInt), Id "x"), Some (EValue (ValInt 1))) + ; SWhile + ( EBinOp (OpLess, EId (Id "x"), EValue (ValInt 1)) + , SBlock + [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) + ; SBreak + ; SContinue + ] ) ]) +;; let%test "Parse for" = - apply_parser parse_block + apply_parser + parse_block {|{ for (int i = 1;i < 5; i = i+1) { @@ -204,30 +189,29 @@ let%test "Parse for" = }|} = Ok (SBlock - [ - SFor + [ SFor ( Some (SDecl - ( Var (TypeVar (TypeBase TypeInt), Id "i"), - Some (EValue (ValInt 1)) )), - Some (EBinOp (OpLess, EId (Id "i"), EValue (ValInt 5))), - Some + (Var (TypeVar (TypeBase TypeInt), Id "i"), Some (EValue (ValInt 1)))) + , Some (EBinOp (OpLess, EId (Id "i"), EValue (ValInt 5))) + , Some (EBinOp - ( OpAssign, - EId (Id "i"), - EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )), - SBlock - [ - SExpr + ( OpAssign + , EId (Id "i") + , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) + , SBlock + [ SExpr (EBinOp - ( OpAssign, - EId (Id "i"), - EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )); - ] ); + ( OpAssign + , EId (Id "i") + , EBinOp (OpAdd, EId (Id "i"), EValue (ValInt 1)) )) + ] ) ]) +;; let%test "Parse if" = - apply_parser parse_block + apply_parser + parse_block {|{if (x == 5) x=1; else if (x == 2) @@ -237,37 +221,37 @@ let%test "Parse if" = }|} = Ok (SBlock - [ - SIf - ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 5)), - SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 1))), - Some + [ SIf + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 5)) + , SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 1))) + , Some (SIf - ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 2)), - SBlock - [ - SExpr - (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))); - ], - None )) ); + ( EBinOp (OpEqual, EId (Id "x"), EValue (ValInt 2)) + , SBlock + [ SExpr (EBinOp (OpAssign, EId (Id "x"), EValue (ValInt 2))) ] + , None )) ) ]) +;; let%test "Parse field 1" = apply_parser parse_field_member {|public int X;|} = Ok (VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None)) +;; let%test "Parse field 2" = apply_parser parse_field_member {|public int X = 1;|} = Ok (VarField - ( [ MPublic ], - TypeVar (TypeBase TypeInt), - Id "X", - Some (EBinOp (OpAssign, EId (Id "X"), EValue (ValInt 1))) )) + ( [ MPublic ] + , TypeVar (TypeBase TypeInt) + , Id "X" + , Some (EBinOp (OpAssign, EId (Id "X"), EValue (ValInt 1))) )) +;; let%test "Parse method 1" = apply_parser parse_method_member {|public int Func() {}|} = Ok (Method ([ MPublic ], TypeBase TypeInt, Id "Func", Params [], SBlock [])) +;; let%test "Parse method 2" = apply_parser parse_method_member {|public int Func() @@ -276,14 +260,16 @@ let%test "Parse method 2" = }|} = Ok (Method - ( [ MPublic ], - TypeBase TypeInt, - Id "Func", - Params [], - SBlock [ SReturn (Some (EValue (ValInt 2))) ] )) + ( [ MPublic ] + , TypeBase TypeInt + , Id "Func" + , Params [] + , SBlock [ SReturn (Some (EValue (ValInt 2))) ] )) +;; let%test "Parse method 3" = - apply_parser parse_method_member + apply_parser + parse_method_member {|public int Factorial(int n) { if (n == 0) @@ -297,42 +283,39 @@ let%test "Parse method 3" = }|} = Ok (Method - ( [ MPublic ], - TypeBase TypeInt, - Id "Factorial", - Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ], - SBlock - [ - SIf - ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)), - SBlock [ SReturn (Some (EValue (ValInt 1))) ], - Some + ( [ MPublic ] + , TypeBase TypeInt + , Id "Factorial" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] + , SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) + , SBlock [ SReturn (Some (EValue (ValInt 1))) ] + , Some (SBlock - [ - SReturn + [ SReturn (Some (EBinOp - ( OpMul, - EId (Id "n"), - EFuncCall - ( EId (Id "Factorial"), - Args - [ - EBinOp - ( OpSub, - EId (Id "n"), - EValue (ValInt 1) ); - ] ) ))); - ]) ); + ( OpMul + , EId (Id "n") + , EFuncCall + ( EId (Id "Factorial") + , Args + [ EBinOp (OpSub, EId (Id "n"), EValue (ValInt 1)) + ] ) ))) + ]) ) ] )) +;; let%test "Parse class 1" = apply_parser parse_class {| public class Sample {}|} = Ok (Class ([ MPublic ], Id "Sample", [])) +;; let%test "Parse class 2" = - apply_parser parse_class + apply_parser + parse_class {| public class Sample { public int X; @@ -340,19 +323,20 @@ let%test "Parse class 2" = }|} = Ok (Class - ( [ MPublic ], - Id "Sample", - [ - VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None); - VarField - ( [ MPublic ], - TypeVar (TypeBase TypeInt), - Id "Y", - Some (EBinOp (OpAssign, EId (Id "Y"), EValue (ValInt 1))) ); + ( [ MPublic ] + , Id "Sample" + , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) + ; VarField + ( [ MPublic ] + , TypeVar (TypeBase TypeInt) + , Id "Y" + , Some (EBinOp (OpAssign, EId (Id "Y"), EValue (ValInt 1))) ) ] )) +;; let%test "Parse class 3" = - apply_parser parse_class + apply_parser + parse_class {| public class Sample { @@ -364,27 +348,27 @@ let%test "Parse class 3" = }|} = Ok (Class - ( [ MPublic ], - Id "Sample", - [ - VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None); - Method - ( [ MPublic ], - TypeBase TypeInt, - Id "add", - Params [ Var (TypeVar (TypeBase TypeInt), Id "x") ], - SBlock - [ - SExpr + ( [ MPublic ] + , Id "Sample" + , [ VarField ([ MPublic ], TypeVar (TypeBase TypeInt), Id "X", None) + ; Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "add" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "x") ] + , SBlock + [ SExpr (EBinOp - ( OpAssign, - EId (Id "X"), - EBinOp (OpAdd, EId (Id "X"), EId (Id "x")) )); - ] ); + ( OpAssign + , EId (Id "X") + , EBinOp (OpAdd, EId (Id "X"), EId (Id "x")) )) + ] ) ] )) +;; let%test "Parse factorial" = - apply_parser parse_prog + apply_parser + parse_prog {| public class Program { @@ -407,45 +391,37 @@ let%test "Parse factorial" = = Ok (Program (Class - ( [ MPublic ], - Id "Program", - [ - Method - ( [ MPublic; MStatic ], - TypeVoid, - Id "Main", - Params [], - SBlock [] ); - Method - ( [ MPublic ], - TypeBase TypeInt, - Id "Factorial", - Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ], - SBlock - [ - SIf - ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)), - SBlock [ SReturn (Some (EValue (ValInt 1))) ], - Some + ( [ MPublic ] + , Id "Program" + , [ Method ([ MPublic; MStatic ], TypeVoid, Id "Main", Params [], SBlock []) + ; Method + ( [ MPublic ] + , TypeBase TypeInt + , Id "Factorial" + , Params [ Var (TypeVar (TypeBase TypeInt), Id "n") ] + , SBlock + [ SIf + ( EBinOp (OpEqual, EId (Id "n"), EValue (ValInt 0)) + , SBlock [ SReturn (Some (EValue (ValInt 1))) ] + , Some (SBlock - [ - SReturn + [ SReturn (Some (EBinOp - ( OpMul, - EId (Id "n"), - EFuncCall - ( EId (Id "Factorial"), - Args - [ - EBinOp - ( OpSub, - EId (Id "n"), - EValue (ValInt 1) ); - ] ) ))); - ]) ); - ] ); + ( OpMul + , EId (Id "n") + , EFuncCall + ( EId (Id "Factorial") + , Args + [ EBinOp + ( OpSub + , EId (Id "n") + , EValue (ValInt 1) ) + ] ) ))) + ]) ) + ] ) ] ))) +;; let%test "parse program with weird whitespace" = let program = @@ -463,7 +439,10 @@ let%test "parse program with weird whitespace" = } |} in - match apply_parser parse_prog program with Ok _ -> true | Error _ -> false + match apply_parser parse_prog program with + | Ok _ -> true + | Error _ -> false +;; let%test "Parse checking fields" = let program = @@ -483,6 +462,9 @@ let%test "Parse checking fields" = } |} in - match apply_parser parse_prog program with Ok _ -> true | Error _ -> false + match apply_parser parse_prog program with + | Ok _ -> true + | Error _ -> false +;; (* TODO: rewrite to normal *) diff --git a/CSharpStrange/tests/qt_tests.ml b/CSharpStrange/tests/qt_tests.ml index 5f8192f4..043b06c8 100644 --- a/CSharpStrange/tests/qt_tests.ml +++ b/CSharpStrange/tests/qt_tests.ml @@ -8,9 +8,8 @@ open Parser (* Ast generators *) let gen_ident = let open Gen in - map - (fun s -> if List.mem s reserved then Id "x" else Id s) - string_small + map (fun s -> if List.mem s reserved then Id "x" else Id s) string_small +;; let gen_ident_length len = let open Gen in @@ -21,92 +20,91 @@ let gen_ident_length len = let s = String.of_seq (List.to_seq chars) in if List.mem s reserved then Id "x" else Id s) char_list_gen +;; let gen_val_type = let open Gen in oneof - [ - map (fun i -> ValInt i) int; - map (fun c -> ValChar c) (char_range 'a' 'z'); - map (fun b -> ValBool b) bool; - map (fun s -> ValString s) string_small; - return ValNull; + [ map (fun i -> ValInt i) int + ; map (fun c -> ValChar c) (char_range 'a' 'z') + ; map (fun b -> ValBool b) bool + ; map (fun s -> ValString s) string_small + ; return ValNull ] +;; let gen_binop = let open Gen in oneof - [ - return OpAdd; - return OpSub; - return OpMul; - return OpDiv; - return OpMod; - return OpEqual; - return OpNonEqual; - return OpLess; - return OpMore; - return OpLessEqual; - return OpMoreEqual; - return OpAnd; - return OpOr; - return OpAssign; + [ return OpAdd + ; return OpSub + ; return OpMul + ; return OpDiv + ; return OpMod + ; return OpEqual + ; return OpNonEqual + ; return OpLess + ; return OpMore + ; return OpLessEqual + ; return OpMoreEqual + ; return OpAnd + ; return OpOr + ; return OpAssign ] +;; let gen_unop = Gen.return OpNot let rec gen_expr depth = let open Gen in - if depth <= 0 then + if depth <= 0 + then (* no recursion *) oneof - [ - map (fun v -> EValue v) gen_val_type; - map (fun id -> EId id) (gen_ident_length 5); + [ map (fun v -> EValue v) gen_val_type + ; map (fun id -> EId id) (gen_ident_length 5) ] - else + else ( let sub = gen_expr (depth - 1) in frequency - [ - (4, sub); - (2, map2 (fun op (l, r) -> EBinOp (op, l, r)) gen_binop (pair sub sub)); - (1, map2 (fun op e -> EUnOp (op, e)) gen_unop sub); - ( 1, - map2 - (fun f args -> EFuncCall (f, Args args)) - sub - (list_size (1 -- 3) sub) ); - ] + [ 4, sub + ; 2, map2 (fun op (l, r) -> EBinOp (op, l, r)) gen_binop (pair sub sub) + ; 1, map2 (fun op e -> EUnOp (op, e)) gen_unop sub + ; 1, map2 (fun f args -> EFuncCall (f, Args args)) sub (list_size (1 -- 3) sub) + ]) +;; let rec gen_stmt depth = let open Gen in - if depth <= 0 then + if depth <= 0 + then oneof - [ - map (fun e -> SExpr e) (gen_expr 2); - map2 + [ map (fun e -> SExpr e) (gen_expr 2) + ; map2 (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) - gen_ident (gen_expr 2); + gen_ident + (gen_expr 2) ] - else + else ( let sub_stmt = gen_stmt (depth - 1) in frequency - [ - (3, map (fun e -> SExpr e) (gen_expr depth)); - ( 2, - map2 + [ 3, map (fun e -> SExpr e) (gen_expr depth) + ; ( 2 + , map2 (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) - gen_ident (gen_expr depth) ); - ( 1, - map3 + gen_ident + (gen_expr depth) ) + ; ( 1 + , map3 (fun cond t e -> SIf (cond, t, e)) - (gen_expr depth) sub_stmt (option sub_stmt) ); - ( 1, - map2 (fun cond body -> SWhile (cond, body)) (gen_expr depth) sub_stmt - ); - (1, map (fun stmts -> SBlock stmts) (list_size (1 -- 5) sub_stmt)); - (1, map (fun e -> SReturn (Some e)) (gen_expr depth)); - ] + (gen_expr depth) + sub_stmt + (option sub_stmt) ) + ; 1, map2 (fun cond body -> SWhile (cond, body)) (gen_expr depth) sub_stmt + ; 1, map (fun stmts -> SBlock stmts) (list_size (1 -- 5) sub_stmt) + ; 1, map (fun e -> SReturn (Some e)) (gen_expr depth) + ]) +;; (* Shrinkers *) @@ -114,8 +112,10 @@ let ( <+> ) = Iter.append let shrink_ident (Id s) = let open Iter in - if String.length s > 1 then return (Id (String.sub s 0 (String.length s - 1))) + if String.length s > 1 + then return (Id (String.sub s 0 (String.length s - 1))) else empty +;; let shrink_val_type = function | ValInt i -> Iter.map (fun i -> ValInt i) (Shrink.int i) @@ -123,49 +123,51 @@ let shrink_val_type = function | ValChar _ -> Iter.return ValNull | ValBool b -> if b then Iter.return (ValBool false) else Iter.empty | ValNull -> Iter.empty +;; let rec shrink_expr = function | EValue v -> Iter.map (fun v' -> EValue v') (shrink_val_type v) | EId id -> Iter.map (fun id' -> EId id') (shrink_ident id) | EBinOp (op, l, r) -> - let open Iter in - return l <+> return r - <+> map (fun l' -> EBinOp (op, l', r)) (shrink_expr l) - <+> map (fun r' -> EBinOp (op, l, r')) (shrink_expr r) - | EUnOp (op, e) -> - Iter.return e <+> Iter.map (fun e' -> EUnOp (op, e')) (shrink_expr e) + let open Iter in + return l + <+> return r + <+> map (fun l' -> EBinOp (op, l', r)) (shrink_expr l) + <+> map (fun r' -> EBinOp (op, l, r')) (shrink_expr r) + | EUnOp (op, e) -> Iter.return e <+> Iter.map (fun e' -> EUnOp (op, e')) (shrink_expr e) | EFuncCall (f, Args []) -> Iter.return f - | EFuncCall (f, Args args) -> ( - let open Iter in - return (EFuncCall (f, Args [])) - <+> map (fun f' -> EFuncCall (f', Args args)) (shrink_expr f) - <+> - match args with + | EFuncCall (f, Args args) -> + let open Iter in + return (EFuncCall (f, Args [])) + <+> map (fun f' -> EFuncCall (f', Args args)) (shrink_expr f) + <+> + (match args with | arg :: rest -> - map (fun arg' -> EFuncCall (f, Args (arg' :: rest))) (shrink_expr arg) - <+> return (EFuncCall (f, Args rest)) + map (fun arg' -> EFuncCall (f, Args (arg' :: rest))) (shrink_expr arg) + <+> return (EFuncCall (f, Args rest)) | [] -> empty) | EArrayAccess _ -> Iter.empty | EAwait _ -> Iter.empty +;; let rec compare_expr_structure e1 e2 = - match (e1, e2) with - | EValue v1, EValue v2 -> ( - match (v1, v2) with - | ValInt _, ValInt _ -> true - | ValChar _, ValChar _ -> true - | ValBool _, ValBool _ -> true - | ValString _, ValString _ -> true - | ValNull, ValNull -> true - | _ -> false) + match e1, e2 with + | EValue v1, EValue v2 -> + (match v1, v2 with + | ValInt _, ValInt _ -> true + | ValChar _, ValChar _ -> true + | ValBool _, ValBool _ -> true + | ValString _, ValString _ -> true + | ValNull, ValNull -> true + | _ -> false) | EId _, EId _ -> true | EBinOp (op1, l1, r1), EBinOp (op2, l2, r2) -> - op1 = op2 && compare_expr_structure l1 l2 && compare_expr_structure r1 r2 - | EUnOp (op1, e1), EUnOp (op2, e2) -> - op1 = op2 && compare_expr_structure e1 e2 + op1 = op2 && compare_expr_structure l1 l2 && compare_expr_structure r1 r2 + | EUnOp (op1, e1), EUnOp (op2, e2) -> op1 = op2 && compare_expr_structure e1 e2 | EFuncCall (f1, Args a1), EFuncCall (f2, Args a2) -> - compare_expr_structure f1 f2 && List.length a1 = List.length a2 + compare_expr_structure f1 f2 && List.length a1 = List.length a2 | _ -> false +;; let add_random_whitespace s = let len = String.length s in @@ -177,15 +179,18 @@ let add_random_whitespace s = if Random.int 5 = 0 then Buffer.add_char buf ' ' done; Buffer.contents buf +;; let expr_arbitrary depth = let gen = gen_expr depth in let shrink = shrink_expr in QCheck.make ~shrink gen +;; let stmt_arbitrary depth = let gen = gen_stmt depth in QCheck.make gen (* TODO: shrink для stmt *) +;; let print_expr out expr = output_string out (Ast.show_expr expr) (* TODO: Pp *) @@ -194,104 +199,119 @@ let test_count = 10 (* Correct parser work *) let prop_parse_no_crash = - Test.make ~name:"Parser does not crash on valid expressions" ~count:test_count - (expr_arbitrary 5) (fun expr -> - let str = Ast.show_expr expr in - match apply_parser Parser.parse_ops str with - | Ok _ -> true - | Error e -> - Printf.printf "\nParse error (but no crash): %s\n%s\n" str e; - true) + Test.make + ~name:"Parser does not crash on valid expressions" + ~count:test_count + (expr_arbitrary 5) + (fun expr -> + let str = Ast.show_expr expr in + match apply_parser Parser.parse_ops str with + | Ok _ -> true + | Error e -> + Printf.printf "\nParse error (but no crash): %s\n%s\n" str e; + true) +;; (* Roundtrip: show -> parse -> show *) let prop_roundtrip_expr = let gen = expr_arbitrary 5 in - Test.make ~name:"Expression roundtrip: show -> parse -> show" - ~count:(test_count / 2) gen (fun expr -> - let str1 = Ast.show_expr expr in - match apply_parser Parser.parse_ops str1 with - | Ok expr' -> - let str2 = Ast.show_expr expr' in - if str1 = str2 then true - else ( - Printf.eprintf "\nRoundtrip failed:\n"; - Printf.eprintf "Original: %s\n" str1; - Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); - Printf.eprintf "Roundtrip:%s\n" str2; - false) - | Error e -> - Printf.eprintf "\nParse failed in roundtrip: %s\n%s\n" str1 e; - false) + Test.make + ~name:"Expression roundtrip: show -> parse -> show" + ~count:(test_count / 2) + gen + (fun expr -> + let str1 = Ast.show_expr expr in + match apply_parser Parser.parse_ops str1 with + | Ok expr' -> + let str2 = Ast.show_expr expr' in + if str1 = str2 + then true + else ( + Printf.eprintf "\nRoundtrip failed:\n"; + Printf.eprintf "Original: %s\n" str1; + Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); + Printf.eprintf "Roundtrip:%s\n" str2; + false) + | Error e -> + Printf.eprintf "\nParse failed in roundtrip: %s\n%s\n" str1 e; + false) +;; (* Operators priority tests *) let prop_operator_precedence = let gen = expr_arbitrary 3 in - Test.make ~name:"Operator precedence is preserved" ~count:(test_count / 2) gen + Test.make + ~name:"Operator precedence is preserved" + ~count:(test_count / 2) + gen (fun expr -> - let str = Ast.show_expr expr in - match apply_parser Parser.parse_ops str with - | Ok expr' -> - if compare_expr_structure expr expr' then true - else ( - Printf.eprintf "\nPrecision failed:\n"; - Printf.eprintf "Original: %s\n" (Ast.show_expr expr); - Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); - false) - | Error _ -> - Printf.eprintf "\nParse failed: %s\n" str; - false) + let str = Ast.show_expr expr in + match apply_parser Parser.parse_ops str with + | Ok expr' -> + if compare_expr_structure expr expr' + then true + else ( + Printf.eprintf "\nPrecision failed:\n"; + Printf.eprintf "Original: %s\n" (Ast.show_expr expr); + Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); + false) + | Error _ -> + Printf.eprintf "\nParse failed: %s\n" str; + false) +;; (* Stmt tests *) let prop_stmt_no_crash = - Test.make ~name:"Statement parser does not crash" ~count:(test_count / 2) - (stmt_arbitrary 3) (fun stmt -> - let str = Ast.show_stmt stmt in - (*TODO: stmt parser *) - true) + Test.make + ~name:"Statement parser does not crash" + ~count:(test_count / 2) + (stmt_arbitrary 3) + (fun stmt -> + let str = Ast.show_stmt stmt in + (*TODO: stmt parser *) + true) +;; (* Correct space pacing *) let prop_whitespace_handling = let gen = expr_arbitrary 3 in - Test.make ~name:"Parser handles whitespace correctly" ~count:(test_count / 5) - gen (fun expr -> - let base_str = Ast.show_expr expr in - let spaced_str = add_random_whitespace base_str in - match - ( apply_parser parse_ops base_str, - apply_parser parse_ops spaced_str ) - with - | Ok expr1, Ok expr2 -> - if compare_expr_structure expr1 expr2 then true - else ( - Printf.eprintf "\nWhitespace handling failed:\n"; - Printf.eprintf "Original (no spaces): %s\n" base_str; - Printf.eprintf "With spaces: %s\n" spaced_str; - Printf.eprintf "Parsed (no spaces): %s\n" (Ast.show_expr expr1); - Printf.eprintf "Parsed (with spaces): %s\n" (Ast.show_expr expr2); - false) - | _ -> false) + Test.make + ~name:"Parser handles whitespace correctly" + ~count:(test_count / 5) + gen + (fun expr -> + let base_str = Ast.show_expr expr in + let spaced_str = add_random_whitespace base_str in + match apply_parser parse_ops base_str, apply_parser parse_ops spaced_str with + | Ok expr1, Ok expr2 -> + if compare_expr_structure expr1 expr2 + then true + else ( + Printf.eprintf "\nWhitespace handling failed:\n"; + Printf.eprintf "Original (no spaces): %s\n" base_str; + Printf.eprintf "With spaces: %s\n" spaced_str; + Printf.eprintf "Parsed (no spaces): %s\n" (Ast.show_expr expr1); + Printf.eprintf "Parsed (with spaces): %s\n" (Ast.show_expr expr2); + false) + | _ -> false) +;; (* Test run *) let () = Random.self_init (); - Printf.printf "\nQUICKCHECK TESTS\n\n"; - let tests = - [ - prop_parse_no_crash; - prop_roundtrip_expr; - prop_operator_precedence; - prop_stmt_no_crash; - prop_whitespace_handling; + [ prop_parse_no_crash + ; prop_roundtrip_expr + ; prop_operator_precedence + ; prop_stmt_no_crash + ; prop_whitespace_handling ] in - Printf.printf "Run %d tests...\n" (List.length tests); - let exit_code = QCheck_runner.run_tests ~verbose:true tests in - Printf.printf "\nRESULTS\n"; - - if exit_code = 0 then Printf.printf "All tests are executed!\n" + if exit_code = 0 + then Printf.printf "All tests are executed!\n" else Printf.printf "Some tests are not executed! (code: %d).\n" exit_code +;; diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange/tests/typecheck_tests.ml index 9d28c1ce..fb857959 100644 --- a/CSharpStrange/tests/typecheck_tests.ml +++ b/CSharpStrange/tests/typecheck_tests.ml @@ -8,11 +8,12 @@ open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Common let show_wrap = function - | Some (Program x) -> ( - match typecheck x with - | _, Result.Ok _ -> Format.print_string "Ok!\n" - | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) + | Some (Program x) -> + (match typecheck x with + | _, Result.Ok _ -> Format.print_string "Ok!\n" + | _, Result.Error e -> Format.printf "%a\n%!" pp_error e) | _ -> Format.print_string "Parsing error\n" +;; let print_tc p str = show_wrap (parse_option p str) let test_ast = print_tc parse_prog @@ -36,6 +37,7 @@ let%expect_test "Factorial" = } |}; [%expect {| Ok! |}] +;; let%expect_test "Wrong factorial" = test_ast @@ -50,10 +52,10 @@ let%expect_test "Wrong factorial" = [%expect {| (TCError (OtherError "Returned type does not match the function type")) |}] +;; let%expect_test "Already declared variable" = - test_ast - {| + test_ast {| class Program { int a = 5; int b = 9; @@ -61,6 +63,7 @@ let%expect_test "Already declared variable" = } |}; [%expect {| (TCError (OtherError "This variable is already declared")) |}] +;; let%expect_test "Checking fields" = test_ast @@ -80,6 +83,7 @@ let%expect_test "Checking fields" = } |}; [%expect {| Ok! |}] +;; (* TODO: parser check! *) @@ -91,6 +95,7 @@ let%expect_test "String + int" = } |}; [%expect {| (TCError TypeMismatch) |}] +;; (* TODO: string! *) @@ -117,6 +122,7 @@ let%expect_test "While" = } |}; [%expect {| Ok! |}] +;; let%expect_test "For" = test_ast @@ -139,6 +145,7 @@ let%expect_test "For" = } |}; [%expect {| Ok! |}] +;; (* TODO: some stuff here! *) @@ -152,6 +159,7 @@ let%expect_test "Wrong main" = {| (TCError (OtherError "Main must be static, non-async, no params, return int/void")) |}] +;; let%expect_test "Already declared function" = test_ast @@ -163,6 +171,7 @@ let%expect_test "Already declared function" = } |}; [%expect {| (TCError (OtherError "This variable is already declared")) |}] +;; let%expect_test "Function type mismatch" = test_ast @@ -174,6 +183,7 @@ let%expect_test "Function type mismatch" = }|}; [%expect {| (TCError TypeMismatch) |}] +;; (* TODO: occurs check: smth like {| From d76c2ea079be3a4c83b835b02bb705387daf3445 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 20:14:44 +0300 Subject: [PATCH 39/84] chore: renamed directory Signed-off-by: f1i3g3 --- {CSharpStrange => CSharpStrange_Kuznetsov}/.ocamlformat | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/CSharpStrange.opam | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/bin/REPL.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/bin/dune | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/bin/factorial.cs | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/dune | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/dune-project | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/ast.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/common.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/common.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/dune | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/interpret.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/interpret.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/monads.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/parser.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/parser.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/prettyprinter.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/prettyprinter.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/typecheck.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/lib/typecheck.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/ast_fact.t | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/dune | 0 .../tests/interpret_tests.ml | 0 .../tests/interpret_tests.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/parser_tests.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/parser_tests.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/pp_tests.ml | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/pp_tests.mli | 0 {CSharpStrange => CSharpStrange_Kuznetsov}/tests/qt_tests.ml | 0 .../tests/typecheck_tests.ml | 0 .../tests/typecheck_tests.mli | 0 31 files changed, 0 insertions(+), 0 deletions(-) rename {CSharpStrange => CSharpStrange_Kuznetsov}/.ocamlformat (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/CSharpStrange.opam (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/bin/REPL.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/bin/dune (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/bin/factorial.cs (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/dune (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/dune-project (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/ast.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/common.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/common.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/dune (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/interpret.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/interpret.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/monads.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/parser.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/parser.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/prettyprinter.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/prettyprinter.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/typecheck.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/lib/typecheck.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/ast_fact.t (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/dune (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/interpret_tests.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/interpret_tests.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/parser_tests.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/parser_tests.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/pp_tests.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/pp_tests.mli (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/qt_tests.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/typecheck_tests.ml (100%) rename {CSharpStrange => CSharpStrange_Kuznetsov}/tests/typecheck_tests.mli (100%) diff --git a/CSharpStrange/.ocamlformat b/CSharpStrange_Kuznetsov/.ocamlformat similarity index 100% rename from CSharpStrange/.ocamlformat rename to CSharpStrange_Kuznetsov/.ocamlformat diff --git a/CSharpStrange/CSharpStrange.opam b/CSharpStrange_Kuznetsov/CSharpStrange.opam similarity index 100% rename from CSharpStrange/CSharpStrange.opam rename to CSharpStrange_Kuznetsov/CSharpStrange.opam diff --git a/CSharpStrange/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml similarity index 100% rename from CSharpStrange/bin/REPL.ml rename to CSharpStrange_Kuznetsov/bin/REPL.ml diff --git a/CSharpStrange/bin/dune b/CSharpStrange_Kuznetsov/bin/dune similarity index 100% rename from CSharpStrange/bin/dune rename to CSharpStrange_Kuznetsov/bin/dune diff --git a/CSharpStrange/bin/factorial.cs b/CSharpStrange_Kuznetsov/bin/factorial.cs similarity index 100% rename from CSharpStrange/bin/factorial.cs rename to CSharpStrange_Kuznetsov/bin/factorial.cs diff --git a/CSharpStrange/dune b/CSharpStrange_Kuznetsov/dune similarity index 100% rename from CSharpStrange/dune rename to CSharpStrange_Kuznetsov/dune diff --git a/CSharpStrange/dune-project b/CSharpStrange_Kuznetsov/dune-project similarity index 100% rename from CSharpStrange/dune-project rename to CSharpStrange_Kuznetsov/dune-project diff --git a/CSharpStrange/lib/ast.ml b/CSharpStrange_Kuznetsov/lib/ast.ml similarity index 100% rename from CSharpStrange/lib/ast.ml rename to CSharpStrange_Kuznetsov/lib/ast.ml diff --git a/CSharpStrange/lib/common.ml b/CSharpStrange_Kuznetsov/lib/common.ml similarity index 100% rename from CSharpStrange/lib/common.ml rename to CSharpStrange_Kuznetsov/lib/common.ml diff --git a/CSharpStrange/lib/common.mli b/CSharpStrange_Kuznetsov/lib/common.mli similarity index 100% rename from CSharpStrange/lib/common.mli rename to CSharpStrange_Kuznetsov/lib/common.mli diff --git a/CSharpStrange/lib/dune b/CSharpStrange_Kuznetsov/lib/dune similarity index 100% rename from CSharpStrange/lib/dune rename to CSharpStrange_Kuznetsov/lib/dune diff --git a/CSharpStrange/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml similarity index 100% rename from CSharpStrange/lib/interpret.ml rename to CSharpStrange_Kuznetsov/lib/interpret.ml diff --git a/CSharpStrange/lib/interpret.mli b/CSharpStrange_Kuznetsov/lib/interpret.mli similarity index 100% rename from CSharpStrange/lib/interpret.mli rename to CSharpStrange_Kuznetsov/lib/interpret.mli diff --git a/CSharpStrange/lib/monads.ml b/CSharpStrange_Kuznetsov/lib/monads.ml similarity index 100% rename from CSharpStrange/lib/monads.ml rename to CSharpStrange_Kuznetsov/lib/monads.ml diff --git a/CSharpStrange/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml similarity index 100% rename from CSharpStrange/lib/parser.ml rename to CSharpStrange_Kuznetsov/lib/parser.ml diff --git a/CSharpStrange/lib/parser.mli b/CSharpStrange_Kuznetsov/lib/parser.mli similarity index 100% rename from CSharpStrange/lib/parser.mli rename to CSharpStrange_Kuznetsov/lib/parser.mli diff --git a/CSharpStrange/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml similarity index 100% rename from CSharpStrange/lib/prettyprinter.ml rename to CSharpStrange_Kuznetsov/lib/prettyprinter.ml diff --git a/CSharpStrange/lib/prettyprinter.mli b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli similarity index 100% rename from CSharpStrange/lib/prettyprinter.mli rename to CSharpStrange_Kuznetsov/lib/prettyprinter.mli diff --git a/CSharpStrange/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml similarity index 100% rename from CSharpStrange/lib/typecheck.ml rename to CSharpStrange_Kuznetsov/lib/typecheck.ml diff --git a/CSharpStrange/lib/typecheck.mli b/CSharpStrange_Kuznetsov/lib/typecheck.mli similarity index 100% rename from CSharpStrange/lib/typecheck.mli rename to CSharpStrange_Kuznetsov/lib/typecheck.mli diff --git a/CSharpStrange/tests/ast_fact.t b/CSharpStrange_Kuznetsov/tests/ast_fact.t similarity index 100% rename from CSharpStrange/tests/ast_fact.t rename to CSharpStrange_Kuznetsov/tests/ast_fact.t diff --git a/CSharpStrange/tests/dune b/CSharpStrange_Kuznetsov/tests/dune similarity index 100% rename from CSharpStrange/tests/dune rename to CSharpStrange_Kuznetsov/tests/dune diff --git a/CSharpStrange/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml similarity index 100% rename from CSharpStrange/tests/interpret_tests.ml rename to CSharpStrange_Kuznetsov/tests/interpret_tests.ml diff --git a/CSharpStrange/tests/interpret_tests.mli b/CSharpStrange_Kuznetsov/tests/interpret_tests.mli similarity index 100% rename from CSharpStrange/tests/interpret_tests.mli rename to CSharpStrange_Kuznetsov/tests/interpret_tests.mli diff --git a/CSharpStrange/tests/parser_tests.ml b/CSharpStrange_Kuznetsov/tests/parser_tests.ml similarity index 100% rename from CSharpStrange/tests/parser_tests.ml rename to CSharpStrange_Kuznetsov/tests/parser_tests.ml diff --git a/CSharpStrange/tests/parser_tests.mli b/CSharpStrange_Kuznetsov/tests/parser_tests.mli similarity index 100% rename from CSharpStrange/tests/parser_tests.mli rename to CSharpStrange_Kuznetsov/tests/parser_tests.mli diff --git a/CSharpStrange/tests/pp_tests.ml b/CSharpStrange_Kuznetsov/tests/pp_tests.ml similarity index 100% rename from CSharpStrange/tests/pp_tests.ml rename to CSharpStrange_Kuznetsov/tests/pp_tests.ml diff --git a/CSharpStrange/tests/pp_tests.mli b/CSharpStrange_Kuznetsov/tests/pp_tests.mli similarity index 100% rename from CSharpStrange/tests/pp_tests.mli rename to CSharpStrange_Kuznetsov/tests/pp_tests.mli diff --git a/CSharpStrange/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml similarity index 100% rename from CSharpStrange/tests/qt_tests.ml rename to CSharpStrange_Kuznetsov/tests/qt_tests.ml diff --git a/CSharpStrange/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml similarity index 100% rename from CSharpStrange/tests/typecheck_tests.ml rename to CSharpStrange_Kuznetsov/tests/typecheck_tests.ml diff --git a/CSharpStrange/tests/typecheck_tests.mli b/CSharpStrange_Kuznetsov/tests/typecheck_tests.mli similarity index 100% rename from CSharpStrange/tests/typecheck_tests.mli rename to CSharpStrange_Kuznetsov/tests/typecheck_tests.mli From db17cbf0977780da906e6c4365a8231a8df76529 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 21:09:22 +0300 Subject: [PATCH 40/84] chore: removed quickcheck, will readd it later Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/dune | 2 +- CSharpStrange_Kuznetsov/tests/qt_tests.ml | 317 ---------------------- 2 files changed, 1 insertion(+), 318 deletions(-) delete mode 100644 CSharpStrange_Kuznetsov/tests/qt_tests.ml diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index dd8efe55..fb245d54 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -1,7 +1,7 @@ (library (name tests) (public_name CSharpStrange.Lib.Tests) - (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests Qt_tests) + (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests) (libraries angstrom c_sharp_strange_lib qcheck) (inline_tests) (instrumentation diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml deleted file mode 100644 index 043b06c8..00000000 --- a/CSharpStrange_Kuznetsov/tests/qt_tests.ml +++ /dev/null @@ -1,317 +0,0 @@ -(* TODO: refactor + add to README *) - -open C_sharp_strange_lib -open QCheck -open Ast -open Parser - -(* Ast generators *) -let gen_ident = - let open Gen in - map (fun s -> if List.mem s reserved then Id "x" else Id s) string_small -;; - -let gen_ident_length len = - let open Gen in - let char_gen = char_range 'a' 'z' in - let char_list_gen = list_size (return len) char_gen in - map - (fun chars -> - let s = String.of_seq (List.to_seq chars) in - if List.mem s reserved then Id "x" else Id s) - char_list_gen -;; - -let gen_val_type = - let open Gen in - oneof - [ map (fun i -> ValInt i) int - ; map (fun c -> ValChar c) (char_range 'a' 'z') - ; map (fun b -> ValBool b) bool - ; map (fun s -> ValString s) string_small - ; return ValNull - ] -;; - -let gen_binop = - let open Gen in - oneof - [ return OpAdd - ; return OpSub - ; return OpMul - ; return OpDiv - ; return OpMod - ; return OpEqual - ; return OpNonEqual - ; return OpLess - ; return OpMore - ; return OpLessEqual - ; return OpMoreEqual - ; return OpAnd - ; return OpOr - ; return OpAssign - ] -;; - -let gen_unop = Gen.return OpNot - -let rec gen_expr depth = - let open Gen in - if depth <= 0 - then - (* no recursion *) - oneof - [ map (fun v -> EValue v) gen_val_type - ; map (fun id -> EId id) (gen_ident_length 5) - ] - else ( - let sub = gen_expr (depth - 1) in - frequency - [ 4, sub - ; 2, map2 (fun op (l, r) -> EBinOp (op, l, r)) gen_binop (pair sub sub) - ; 1, map2 (fun op e -> EUnOp (op, e)) gen_unop sub - ; 1, map2 (fun f args -> EFuncCall (f, Args args)) sub (list_size (1 -- 3) sub) - ]) -;; - -let rec gen_stmt depth = - let open Gen in - if depth <= 0 - then - oneof - [ map (fun e -> SExpr e) (gen_expr 2) - ; map2 - (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) - gen_ident - (gen_expr 2) - ] - else ( - let sub_stmt = gen_stmt (depth - 1) in - frequency - [ 3, map (fun e -> SExpr e) (gen_expr depth) - ; ( 2 - , map2 - (fun id e -> SDecl (Var (TypeVar (TypeBase TypeInt), id), Some e)) - gen_ident - (gen_expr depth) ) - ; ( 1 - , map3 - (fun cond t e -> SIf (cond, t, e)) - (gen_expr depth) - sub_stmt - (option sub_stmt) ) - ; 1, map2 (fun cond body -> SWhile (cond, body)) (gen_expr depth) sub_stmt - ; 1, map (fun stmts -> SBlock stmts) (list_size (1 -- 5) sub_stmt) - ; 1, map (fun e -> SReturn (Some e)) (gen_expr depth) - ]) -;; - -(* Shrinkers *) - -let ( <+> ) = Iter.append - -let shrink_ident (Id s) = - let open Iter in - if String.length s > 1 - then return (Id (String.sub s 0 (String.length s - 1))) - else empty -;; - -let shrink_val_type = function - | ValInt i -> Iter.map (fun i -> ValInt i) (Shrink.int i) - | ValString s -> Iter.map (fun s -> ValString s) (Shrink.string s) - | ValChar _ -> Iter.return ValNull - | ValBool b -> if b then Iter.return (ValBool false) else Iter.empty - | ValNull -> Iter.empty -;; - -let rec shrink_expr = function - | EValue v -> Iter.map (fun v' -> EValue v') (shrink_val_type v) - | EId id -> Iter.map (fun id' -> EId id') (shrink_ident id) - | EBinOp (op, l, r) -> - let open Iter in - return l - <+> return r - <+> map (fun l' -> EBinOp (op, l', r)) (shrink_expr l) - <+> map (fun r' -> EBinOp (op, l, r')) (shrink_expr r) - | EUnOp (op, e) -> Iter.return e <+> Iter.map (fun e' -> EUnOp (op, e')) (shrink_expr e) - | EFuncCall (f, Args []) -> Iter.return f - | EFuncCall (f, Args args) -> - let open Iter in - return (EFuncCall (f, Args [])) - <+> map (fun f' -> EFuncCall (f', Args args)) (shrink_expr f) - <+> - (match args with - | arg :: rest -> - map (fun arg' -> EFuncCall (f, Args (arg' :: rest))) (shrink_expr arg) - <+> return (EFuncCall (f, Args rest)) - | [] -> empty) - | EArrayAccess _ -> Iter.empty - | EAwait _ -> Iter.empty -;; - -let rec compare_expr_structure e1 e2 = - match e1, e2 with - | EValue v1, EValue v2 -> - (match v1, v2 with - | ValInt _, ValInt _ -> true - | ValChar _, ValChar _ -> true - | ValBool _, ValBool _ -> true - | ValString _, ValString _ -> true - | ValNull, ValNull -> true - | _ -> false) - | EId _, EId _ -> true - | EBinOp (op1, l1, r1), EBinOp (op2, l2, r2) -> - op1 = op2 && compare_expr_structure l1 l2 && compare_expr_structure r1 r2 - | EUnOp (op1, e1), EUnOp (op2, e2) -> op1 = op2 && compare_expr_structure e1 e2 - | EFuncCall (f1, Args a1), EFuncCall (f2, Args a2) -> - compare_expr_structure f1 f2 && List.length a1 = List.length a2 - | _ -> false -;; - -let add_random_whitespace s = - let len = String.length s in - let buf = Buffer.create (len * 2) in - for i = 0 to len - 1 do - (* TODO: proper constant *) - if Random.int 5 = 0 then Buffer.add_char buf ' '; - Buffer.add_char buf s.[i]; - if Random.int 5 = 0 then Buffer.add_char buf ' ' - done; - Buffer.contents buf -;; - -let expr_arbitrary depth = - let gen = gen_expr depth in - let shrink = shrink_expr in - QCheck.make ~shrink gen -;; - -let stmt_arbitrary depth = - let gen = gen_stmt depth in - QCheck.make gen (* TODO: shrink для stmt *) -;; - -let print_expr out expr = output_string out (Ast.show_expr expr) -(* TODO: Pp *) - -let test_count = 10 - -(* Correct parser work *) -let prop_parse_no_crash = - Test.make - ~name:"Parser does not crash on valid expressions" - ~count:test_count - (expr_arbitrary 5) - (fun expr -> - let str = Ast.show_expr expr in - match apply_parser Parser.parse_ops str with - | Ok _ -> true - | Error e -> - Printf.printf "\nParse error (but no crash): %s\n%s\n" str e; - true) -;; - -(* Roundtrip: show -> parse -> show *) -let prop_roundtrip_expr = - let gen = expr_arbitrary 5 in - Test.make - ~name:"Expression roundtrip: show -> parse -> show" - ~count:(test_count / 2) - gen - (fun expr -> - let str1 = Ast.show_expr expr in - match apply_parser Parser.parse_ops str1 with - | Ok expr' -> - let str2 = Ast.show_expr expr' in - if str1 = str2 - then true - else ( - Printf.eprintf "\nRoundtrip failed:\n"; - Printf.eprintf "Original: %s\n" str1; - Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); - Printf.eprintf "Roundtrip:%s\n" str2; - false) - | Error e -> - Printf.eprintf "\nParse failed in roundtrip: %s\n%s\n" str1 e; - false) -;; - -(* Operators priority tests *) -let prop_operator_precedence = - let gen = expr_arbitrary 3 in - Test.make - ~name:"Operator precedence is preserved" - ~count:(test_count / 2) - gen - (fun expr -> - let str = Ast.show_expr expr in - match apply_parser Parser.parse_ops str with - | Ok expr' -> - if compare_expr_structure expr expr' - then true - else ( - Printf.eprintf "\nPrecision failed:\n"; - Printf.eprintf "Original: %s\n" (Ast.show_expr expr); - Printf.eprintf "Parsed: %s\n" (Ast.show_expr expr'); - false) - | Error _ -> - Printf.eprintf "\nParse failed: %s\n" str; - false) -;; - -(* Stmt tests *) -let prop_stmt_no_crash = - Test.make - ~name:"Statement parser does not crash" - ~count:(test_count / 2) - (stmt_arbitrary 3) - (fun stmt -> - let str = Ast.show_stmt stmt in - (*TODO: stmt parser *) - true) -;; - -(* Correct space pacing *) -let prop_whitespace_handling = - let gen = expr_arbitrary 3 in - Test.make - ~name:"Parser handles whitespace correctly" - ~count:(test_count / 5) - gen - (fun expr -> - let base_str = Ast.show_expr expr in - let spaced_str = add_random_whitespace base_str in - match apply_parser parse_ops base_str, apply_parser parse_ops spaced_str with - | Ok expr1, Ok expr2 -> - if compare_expr_structure expr1 expr2 - then true - else ( - Printf.eprintf "\nWhitespace handling failed:\n"; - Printf.eprintf "Original (no spaces): %s\n" base_str; - Printf.eprintf "With spaces: %s\n" spaced_str; - Printf.eprintf "Parsed (no spaces): %s\n" (Ast.show_expr expr1); - Printf.eprintf "Parsed (with spaces): %s\n" (Ast.show_expr expr2); - false) - | _ -> false) -;; - -(* Test run *) -let () = - Random.self_init (); - Printf.printf "\nQUICKCHECK TESTS\n\n"; - let tests = - [ prop_parse_no_crash - ; prop_roundtrip_expr - ; prop_operator_precedence - ; prop_stmt_no_crash - ; prop_whitespace_handling - ] - in - Printf.printf "Run %d tests...\n" (List.length tests); - let exit_code = QCheck_runner.run_tests ~verbose:true tests in - Printf.printf "\nRESULTS\n"; - if exit_code = 0 - then Printf.printf "All tests are executed!\n" - else Printf.printf "Some tests are not executed! (code: %d).\n" exit_code -;; From d1ce8278f5cea3a3e6d33ce9f3cdb1d3524e013c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 21:10:07 +0300 Subject: [PATCH 41/84] chore: updated dune-project Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/dune-project | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index a526a062..ac72451d 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -10,18 +10,18 @@ (maintainers "Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com") -(bug_reports "https://github.com/f1i3g3/fp2024") +(bug_reports "https://github.com/f1i3g3/fp25") -(homepage "https://github.com/f1i3g3/fp2024") +(homepage "https://github.com/f1i3g3/fp25") (package (name CSharpStrange) (synopsis "An interpreter for strange subset of C# language") (description - "An interpreter for subset of C# language with async/await and LINQ (and some other stuff which will be added later)") + "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)") ; TODO: actual documentation (documentation "https://kakadu.github.io/fp2024/docs/Lambda") ; TODO: update old links - (version 0.1) + (version 0.2) (depends dune angstrom From 39c3eca358590947e636614ed7a109d5e2363751 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 21:11:37 +0300 Subject: [PATCH 42/84] chore: updated dune-project Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/dune-project | 1 - 1 file changed, 1 deletion(-) diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index ac72451d..d5a6b659 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -20,7 +20,6 @@ (description "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)") ; TODO: actual documentation (documentation "https://kakadu.github.io/fp2024/docs/Lambda") - ; TODO: update old links (version 0.2) (depends dune From 9d0249f46b71bbb8c5978e6c54c919ea56ed02cd Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 21:57:59 +0300 Subject: [PATCH 43/84] fix: linter fixes Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/CSharpStrange.opam | 8 +-- CSharpStrange_Kuznetsov/bin/REPL.ml | 3 +- CSharpStrange_Kuznetsov/lib/ast.ml | 2 +- CSharpStrange_Kuznetsov/lib/common.ml | 2 +- CSharpStrange_Kuznetsov/lib/common.mli | 2 +- CSharpStrange_Kuznetsov/lib/interpret.ml | 23 +++--- CSharpStrange_Kuznetsov/lib/interpret.mli | 2 +- CSharpStrange_Kuznetsov/lib/monads.ml | 8 ++- CSharpStrange_Kuznetsov/lib/monads.mli | 72 +++++++++++++++++++ CSharpStrange_Kuznetsov/lib/parser.ml | 5 +- CSharpStrange_Kuznetsov/lib/parser.mli | 2 +- CSharpStrange_Kuznetsov/lib/prettyprinter.ml | 3 +- CSharpStrange_Kuznetsov/lib/prettyprinter.mli | 2 +- CSharpStrange_Kuznetsov/lib/typecheck.ml | 71 ++++++++---------- CSharpStrange_Kuznetsov/lib/typecheck.mli | 3 +- .../tests/interpret_tests.ml | 3 +- .../tests/interpret_tests.mli | 2 +- CSharpStrange_Kuznetsov/tests/parser_tests.ml | 2 +- .../tests/parser_tests.mli | 2 +- CSharpStrange_Kuznetsov/tests/pp_tests.ml | 2 +- CSharpStrange_Kuznetsov/tests/pp_tests.mli | 2 +- .../tests/typecheck_tests.ml | 2 +- .../tests/typecheck_tests.mli | 2 +- 23 files changed, 144 insertions(+), 81 deletions(-) create mode 100644 CSharpStrange_Kuznetsov/lib/monads.mli diff --git a/CSharpStrange_Kuznetsov/CSharpStrange.opam b/CSharpStrange_Kuznetsov/CSharpStrange.opam index 7e5c764d..d534b6a7 100644 --- a/CSharpStrange_Kuznetsov/CSharpStrange.opam +++ b/CSharpStrange_Kuznetsov/CSharpStrange.opam @@ -1,14 +1,14 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "0.1" +version: "0.2" synopsis: "An interpreter for strange subset of C# language" description: - "An interpreter for subset of C# language with async/await and LINQ (and some other stuff which will be added later)" + "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)" maintainer: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] authors: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] license: "LGPL-3.0-or-later" -homepage: "https://github.com/f1i3g3/fp2024" -bug-reports: "https://github.com/f1i3g3/fp2024" +homepage: "https://github.com/f1i3g3/fp25" +bug-reports: "https://github.com/f1i3g3/fp25" depends: [ "dune" {>= "3.7"} "angstrom" diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 05e451b5..beb20658 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -1,11 +1,10 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Ast open C_sharp_strange_lib.Parser open C_sharp_strange_lib.Interpret -open C_sharp_strange_lib.Common open Printf open Stdio diff --git a/CSharpStrange_Kuznetsov/lib/ast.ml b/CSharpStrange_Kuznetsov/lib/ast.ml index 06fdaa46..5a6aedcc 100644 --- a/CSharpStrange_Kuznetsov/lib/ast.ml +++ b/CSharpStrange_Kuznetsov/lib/ast.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/common.ml b/CSharpStrange_Kuznetsov/lib/common.ml index 9958a5cc..736aba41 100644 --- a/CSharpStrange_Kuznetsov/lib/common.ml +++ b/CSharpStrange_Kuznetsov/lib/common.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 20265, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/common.mli b/CSharpStrange_Kuznetsov/lib/common.mli index 9842da74..9a38bb3d 100644 --- a/CSharpStrange_Kuznetsov/lib/common.mli +++ b/CSharpStrange_Kuznetsov/lib/common.mli @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index ec437a59..a3230281 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -40,7 +40,7 @@ type value = | VObject of adr [@@deriving show { with_path = false }] -and func = +type func = { params : ident list ; body : stmt } @@ -68,9 +68,9 @@ type object_state = ; fields : (ident * field_value) list } +(*TODO name*) type class_def = - { name : ident - ; fields : (ident * _type * expr option * bool) list + { fields : (ident * _type * expr option * bool) list ; methods : (ident * func) list } @@ -84,11 +84,11 @@ type runtime = ; static_fields : (ident * value) list } -let rec pp_value fmt = function +let pp_value fmt = function | VInt i -> Format.fprintf fmt "%d" i | VBool b -> Format.fprintf fmt "%b" b | VChar c -> Format.fprintf fmt "'%c'" c - | VString s -> Format.fprintf fmt "\"%s\"" s + | VString s -> Format.fprintf fmt "\"%S\"" s | VNull -> Format.fprintf fmt "null" | VObject (Adr a) -> Format.fprintf fmt "object@%d" a ;; @@ -232,16 +232,16 @@ let var_field_of_ast = function ;; let method_of_ast = function - | Method (mods, ret_type, id, Params params, body) -> + | Method (_, _, id, Params params, body) -> let params_list = List.map (fun (Var (_, id)) -> id) params in Some (id, { params = params_list; body }) | VarField _ -> None ;; -let class_of_ast (Class (mods, name, fields)) = +let class_of_ast (Class (_, _, fields)) = let fields_list = List.filter_map var_field_of_ast fields in let methods_list = List.filter_map method_of_ast fields in - { name; fields = fields_list; methods = methods_list } + { fields = fields_list; methods = methods_list } ;; let find_field obj_id field_id rt = @@ -277,7 +277,7 @@ let find_static_field field_id rt = let update_static_field field_id new_value rt = let rec update_static_list = function | [] -> [ field_id, new_value ] - | (id, v) :: rest when id = field_id -> (id, new_value) :: rest + | (id, _) :: rest when id = field_id -> (id, new_value) :: rest | (id, v) :: rest -> (id, v) :: update_static_list rest in { rt with static_fields = update_static_list rt.static_fields } @@ -603,8 +603,7 @@ let init_program (Class (_, name, fields)) = Ok (None, rt4) ;; -let interpret_program prog = - match prog with +let interpret_program = function | Program cls -> (match init_program cls with | Ok (_, rt) -> diff --git a/CSharpStrange_Kuznetsov/lib/interpret.mli b/CSharpStrange_Kuznetsov/lib/interpret.mli index 73618212..b0113251 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.mli +++ b/CSharpStrange_Kuznetsov/lib/interpret.mli @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/monads.ml b/CSharpStrange_Kuznetsov/lib/monads.ml index 3e437ce5..9f1fc1d1 100644 --- a/CSharpStrange_Kuznetsov/lib/monads.ml +++ b/CSharpStrange_Kuznetsov/lib/monads.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -8,7 +8,7 @@ module STATEERROR = struct type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t let return : 'a -> ('st, 'a) t = fun x st -> st, Result.Ok x - let fail : 'a -> ('st, 'b) t = fun e st -> st, Result.Error e + let fail e st = st, Result.Error e let ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t = fun x f st -> @@ -18,6 +18,7 @@ module STATEERROR = struct | Result.Error e -> fail e st ;; + let ( let* ) = ( >>= ) let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = fun x1 x2 -> x1 >>= fun _ -> x2 let ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t = @@ -61,7 +62,8 @@ module STATEERROR = struct List.fold_left f (return ()) list ;; - let run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t = fun f st -> f st + (*('st, 'a) t -> 'st -> 'st * ('a, error) Result.t *) + let run f st = f st end module TYPECHECK = struct diff --git a/CSharpStrange_Kuznetsov/lib/monads.mli b/CSharpStrange_Kuznetsov/lib/monads.mli new file mode 100644 index 00000000..d04425d8 --- /dev/null +++ b/CSharpStrange_Kuznetsov/lib/monads.mli @@ -0,0 +1,72 @@ +(** Copyright 2026, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common + +(** State + Error monad combinators *) +module STATEERROR : sig + type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t + + val return : 'a -> ('st, 'a) t + val fail : error -> ('st, 'a) t + val ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t + val ( let* ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t + val ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t + val ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t + val ( >>| ) : ('st, 'a) t -> ('a -> 'b) -> ('st, 'b) t + val lift2 : ('a -> 'b -> 'c) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t + + val lift3 + : ('a -> 'b -> 'c -> 'd) + -> ('st, 'a) t + -> ('st, 'b) t + -> ('st, 'c) t + -> ('st, 'd) t + + val read : ('st, 'st) t + val write : 'st -> ('st, unit) t + val map : ('a -> ('st, 'b) t) -> 'a list -> ('st, 'b list) t + val iter : ('a -> ('st, unit) t) -> 'a list -> ('st, unit) t + val run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t +end + +(** Typechecker-specific monad operations *) +module TYPECHECK : sig + open Ast + open Common.TypeCheck + + type 'a t = (TypeCheck.state, 'a) STATEERROR.t + + val return : 'a -> 'a t + val fail : error -> 'a t + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + val ( *> ) : 'a t -> 'b t -> 'b t + val ( <|> ) : 'a t -> 'a t -> 'a t + val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t + val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t + val read_local : Common.obj_content IdMap.t t + val read_local_el : ident -> (Common.obj_content option -> 'a t) -> 'a t + val read_local_el_opt : ident -> Common.obj_content option t + val read_local_el : ident -> Common.obj_content t + val write_local : Common.obj_content IdMap.t -> unit t + val write_local_el : ident -> Common.obj_content -> unit t + val write_meth_type_opt : _type option -> unit t + val write_meth_type : _type -> unit t + val read_global : Common.context IdMap.t t + val read_global_el : ident -> (Common.context option -> 'a t) -> 'a t + val read_global_el_opt : ident -> Common.context option t + val read_global_el : ident -> Common.context t + val read_meth_type : _type option t + val read_main_class : ident option t + val write_main_class : ident option -> unit t + val write_global : Common.context IdMap.t -> unit t + val write_global_el : ident -> Common.context -> unit t + val get_curr_class_name : ident t + val write_curr_class_name : ident -> unit t + val map : ('a -> 'b t) -> 'a list -> 'b list t + val iter : ('a -> unit t) -> 'a list -> unit t + val run : 'a t -> TypeCheck.state -> TypeCheck.state * ('a, error) Result.t +end diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index 73b9a628..cfb85aa0 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -193,7 +193,8 @@ let parse_ops = let lv2 = many (choice [ ( ^!^ ); ( ^!-^ ) ]) >>= fun ops -> - lv1 >>= fun e -> return (List.fold_right ops ~f:(fun op acc -> op acc) ~init:e) + let appl op acc = op acc in + lv1 >>= fun e -> return (List.fold_right ops ~f:appl ~init:e) in (* TODO: rewrite somehow + more ops *) let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in diff --git a/CSharpStrange_Kuznetsov/lib/parser.mli b/CSharpStrange_Kuznetsov/lib/parser.mli index b6f5c7fe..b2530616 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.mli +++ b/CSharpStrange_Kuznetsov/lib/parser.mli @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml index 58fcfab9..35f2b077 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -62,6 +62,7 @@ let pp_bin_op fmt = function | OpAssign -> fprintf fmt "=" ;; +(*TODO*) let pp_un_op fmt = function | OpNot -> fprintf fmt "!" ;; diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli index 949077e6..d55fd9f2 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 54e42d94..2e6a2b88 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -24,22 +24,11 @@ let vardecl_to_type = function | Var (t, _) -> return (vartype_to_type t) ;; -let name_to_obj_ctx n = read_local_el n - -let eq f e1 e2 = - match f e1 e2 with - | true -> return e1 - | false -> fail (TCError TypeMismatch) -;; - +let name_to_obj_ctx = read_local_el +let eq f e1 e2 = if f e1 e2 then return e1 else fail (TCError TypeMismatch) let eq_type t1 t2 = eq equal__type t1 t2 let eq_ident n1 n2 = eq equal_ident n1 n2 - -let eq_ident_return_ctx n1 n2 m f = - match equal_ident n1 n2 with - | true -> Some (f m) - | false -> None -;; +let eq_ident_return_ctx n1 n2 m f = if equal_ident n1 n2 then Some (f m) else None let field_of_ast = function | VarField (mods, typ, id, init) -> @@ -56,7 +45,7 @@ let field_of_ast = function ; field_init = init ; is_static } - | Method _ -> failwith "Expected field, got method" + | Method _ -> failwith "Expected field, got method" (* TODO *) ;; let method_of_ast = function @@ -77,7 +66,7 @@ let method_of_ast = function ; is_static ; is_main } - | Ast.VarField _ -> failwith "Expected method, got field" + | Ast.VarField _ -> failwith "Expected method, got field" (* TODO *) ;; let get_class_memb id memb = @@ -134,13 +123,13 @@ let typecheck_method_args (Params params) (Args args) expr_tc = | Var (t, _) -> vartype_to_type t) p in - let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= find_memb_type) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with | 0 -> - (match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + if List.equal eq l1 l2 + then return rez + else fail (TCError (OtherError "Method invocation check error")) | _ -> fail (TCError (OtherError "Method invocation check error")) in args_to_list_of_type args @@ -148,7 +137,7 @@ let typecheck_method_args (Params params) (Args args) expr_tc = compare_two_lists (params_to_list_of_type params) args equal__type params ;; -let find_expr_type e expr_tc = expr_tc e >>= fun e -> find_memb_type e +let find_expr_type e expr_tc = expr_tc e >>= find_memb_type let typecheck_bin_op b e1 e2 expr_tc = let compare_two_expr_type e1 e2 = @@ -195,13 +184,13 @@ let tc_method_args (Params params) (Args args) expr_tc = | Var (t, _) -> vartype_to_type t) p in - let args_to_list_of_type a = map (fun x -> expr_tc x >>= fun x -> find_memb_type x) a in + let args_to_list_of_type a = map (fun x -> expr_tc x >>= find_memb_type) a in let compare_two_lists l1 l2 eq rez = match List.compare_lengths l1 l2 with | 0 -> - (match List.equal eq l1 l2 with - | true -> return rez - | false -> fail (TCError (OtherError "Method invocation check error"))) + if List.equal eq l1 l2 + then return rez + else fail (TCError (OtherError "Method invocation check error")) | _ -> fail (TCError (OtherError "Method invocation check error")) in args_to_list_of_type args @@ -258,7 +247,7 @@ let typecheck_expr = tc_expr_ ;; -let typecheck_expr_with_type e = typecheck_expr e >>= fun x -> find_memb_type x +let typecheck_expr_with_type e = typecheck_expr e >>= find_memb_type let eq_type_with_expr t e = typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t let save_decl n ctx = @@ -294,8 +283,7 @@ let rec typecheck_stmt = write_local_el n (TCLocalVar var_info) | Some _ -> fail (TCError (OtherError "This variable is already declared")) in - let typecheck_decl t n init_expr = - match init_expr with + let typecheck_decl t n = function | Some e -> eq_type_with_expr t e *> save_decl n t true *> return () | None -> save_decl n t false *> return () in @@ -381,16 +369,19 @@ let tc_member mem class_fields = let m = method_of_ast (Method (mds, tp, id, pms, b)) in if m.is_main then ( - match mds, pms, tp with - | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> - tc_meth tp (Params []) b class_fields *> read_main_class - >>= (function - | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) - | Some _ -> fail (TCError (OtherError "Main method already exists"))) - | _, _, _ -> - fail - (TCError - (OtherError "Main must be static, non-async, no params, return int/void"))) + let handle_main = + match mds, pms, tp with + | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> + tc_meth tp (Params []) b class_fields *> read_main_class + >>= (function + | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) + | Some _ -> fail (TCError (OtherError "Main method already exists"))) + | _, _, _ -> + fail + (TCError + (OtherError "Main must be static, non-async, no params, return int/void")) + in + handle_main) else tc_meth tp pms b class_fields in match mem with @@ -407,7 +398,7 @@ let save_global id ctx = let typecheck_obj cl = match cl with - | Class (mds, id, fields) -> + | Class (_, id, fields) -> let write_mems () = let f mem = match mem with diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.mli b/CSharpStrange_Kuznetsov/lib/typecheck.mli index 35579d9a..b118f770 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.mli +++ b/CSharpStrange_Kuznetsov/lib/typecheck.mli @@ -1,9 +1,8 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Ast -open Monads.TYPECHECK open Common val typecheck : c_sharp_class -> TypeCheck.state * (unit, error) result diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index 12973420..7f50927b 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -1,9 +1,8 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Interpret -open C_sharp_strange_lib.Monads let show_wrap str = match interpret str with diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.mli b/CSharpStrange_Kuznetsov/tests/interpret_tests.mli index 2a5ede90..6b453b16 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.mli +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.mli @@ -1,3 +1,3 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/parser_tests.ml b/CSharpStrange_Kuznetsov/tests/parser_tests.ml index ed185e7d..f586e65b 100644 --- a/CSharpStrange_Kuznetsov/tests/parser_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/parser_tests.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/parser_tests.mli b/CSharpStrange_Kuznetsov/tests/parser_tests.mli index 2a5ede90..6b453b16 100644 --- a/CSharpStrange_Kuznetsov/tests/parser_tests.mli +++ b/CSharpStrange_Kuznetsov/tests/parser_tests.mli @@ -1,3 +1,3 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/pp_tests.ml b/CSharpStrange_Kuznetsov/tests/pp_tests.ml index af45e684..3a4ccba6 100644 --- a/CSharpStrange_Kuznetsov/tests/pp_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/pp_tests.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/pp_tests.mli b/CSharpStrange_Kuznetsov/tests/pp_tests.mli index 2a5ede90..6b453b16 100644 --- a/CSharpStrange_Kuznetsov/tests/pp_tests.mli +++ b/CSharpStrange_Kuznetsov/tests/pp_tests.mli @@ -1,3 +1,3 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index fb857959..cd78b21b 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -1,4 +1,4 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.mli b/CSharpStrange_Kuznetsov/tests/typecheck_tests.mli index 2a5ede90..6b453b16 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.mli +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.mli @@ -1,3 +1,3 @@ -(** Copyright 2025, Dmitrii Kuznetsov *) +(** Copyright 2026, Dmitrii Kuznetsov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From 191f2c3b5cd1427d1a04f9c9e5c15c8a8a29d0ef Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:00:09 +0300 Subject: [PATCH 44/84] fix: another limter fix Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/monads.mli | 1 - CSharpStrange_Kuznetsov/lib/prettyprinter.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/monads.mli b/CSharpStrange_Kuznetsov/lib/monads.mli index d04425d8..6e46a56e 100644 --- a/CSharpStrange_Kuznetsov/lib/monads.mli +++ b/CSharpStrange_Kuznetsov/lib/monads.mli @@ -34,7 +34,6 @@ end (** Typechecker-specific monad operations *) module TYPECHECK : sig open Ast - open Common.TypeCheck type 'a t = (TypeCheck.state, 'a) STATEERROR.t diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml index 35f2b077..f2dd2844 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml @@ -62,9 +62,9 @@ let pp_bin_op fmt = function | OpAssign -> fprintf fmt "=" ;; -(*TODO*) let pp_un_op fmt = function | OpNot -> fprintf fmt "!" + | OpNeg -> fprintf fmt "-" ;; let pp_val_type fmt = function From 284534187438c2e320d4c07968d55d3eb5716ff8 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:06:02 +0300 Subject: [PATCH 45/84] fix: comments fixed to one format Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/common.mli | 28 +++++++++---------- CSharpStrange_Kuznetsov/lib/monads.mli | 4 +-- .../tests/interpret_tests.ml | 10 +++---- .../tests/typecheck_tests.ml | 7 ++--- 4 files changed, 24 insertions(+), 25 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/common.mli b/CSharpStrange_Kuznetsov/lib/common.mli index 9a38bb3d..7f1bf59c 100644 --- a/CSharpStrange_Kuznetsov/lib/common.mli +++ b/CSharpStrange_Kuznetsov/lib/common.mli @@ -4,7 +4,7 @@ open Ast -(** Type checker error types *) +(* Type checker error types *) type tc_error = | NotImplemented | OccursCheck @@ -16,7 +16,7 @@ type tc_error = val pp_tc_error : Format.formatter -> tc_error -> unit val show_tc_error : tc_error -> string -(** Interpreter error types *) +(* Interpreter error types *) type interpret_error = | NotImplemented | NoVariable of string @@ -29,7 +29,7 @@ type interpret_error = val pp_interpret_error : Format.formatter -> interpret_error -> unit val show_interpret_error : interpret_error -> string -(** Combined error type *) +(* Combined error type *) type error = | TCError of tc_error | IError of interpret_error @@ -37,37 +37,37 @@ type error = val pp_error : Format.formatter -> error -> unit val show_error : error -> string -(** Identifier module *) +(* Identifier module *) module Id : sig type t = ident val compare : t -> t -> int end -(** Map from identifiers *) +(* Map from identifiers *) module IdMap : sig include Map.S with type key = ident end -(** Address type *) +(* Address type *) type adr = Adr of int val pp_adr : Format.formatter -> adr -> unit val show_adr : adr -> string -(** Address module *) +(* Address module *) module Adr : sig type t = adr val compare : t -> t -> int end -(** Map from addresses *) +(* Map from addresses *) module AdrMap : sig include Map.S with type key = adr end -(** Variable information for type checker *) +(* Variable information for type checker *) type var_info = { var_type : var_type ; initialized : bool (** Whether the variable has been initialized *) @@ -77,7 +77,7 @@ val pp_var_info : Format.formatter -> var_info -> unit val show_var_info : var_info -> string val equal_var_info : var_info -> var_info -> bool -(** Field information for type checker *) +(* Field information for type checker *) type field_info = { field_modifiers : modifier list ; field_type : var_type @@ -90,7 +90,7 @@ val pp_field_info : Format.formatter -> field_info -> unit val show_field_info : field_info -> string val equal_field_info : field_info -> field_info -> bool -(** Method information for type checker *) +(* Method information for type checker *) type method_info = { method_modifiers : modifier list ; method_return : _type @@ -105,7 +105,7 @@ val pp_method_info : Format.formatter -> method_info -> unit val show_method_info : method_info -> string val equal_method_info : method_info -> method_info -> bool -(** Type checker content types *) +(* Type checker content types *) type obj_content = | TCLocalVar of var_info (** Local variable *) | TCField of field_info (** Class field *) @@ -115,10 +115,10 @@ val pp_obj_content : Format.formatter -> obj_content -> unit val show_obj_content : obj_content -> string val equal_obj_content : obj_content -> obj_content -> bool -(** Global context for type checker *) +(**Global context for type checker *) type context = TCClass of c_sharp_class -(** Type checker state module *) +(* Type checker state module *) module TypeCheck : sig type global_env = context IdMap.t type local_env = obj_content IdMap.t diff --git a/CSharpStrange_Kuznetsov/lib/monads.mli b/CSharpStrange_Kuznetsov/lib/monads.mli index 6e46a56e..d06e4fe0 100644 --- a/CSharpStrange_Kuznetsov/lib/monads.mli +++ b/CSharpStrange_Kuznetsov/lib/monads.mli @@ -4,7 +4,7 @@ open Common -(** State + Error monad combinators *) +(* State + Error monad combinators *) module STATEERROR : sig type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t @@ -31,7 +31,7 @@ module STATEERROR : sig val run : ('st, 'a) t -> 'st -> 'st * ('a, error) Result.t end -(** Typechecker-specific monad operations *) +(* Typechecker-specific monad operations *) module TYPECHECK : sig open Ast diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index 7f50927b..f821d7f8 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -13,7 +13,7 @@ let show_wrap str = | Result.Error er -> Format.printf "%a\n%!" pp_error (IError er) ;; -(* TODO: incluede TC? *) +(* TODO: include TC? *) let%expect_test "Main 1" = show_wrap @@ -39,9 +39,9 @@ let%expect_test "Main 1" = Result: '-58' |}] ;; -(* TODO: Доступ к нестатическим полям из статического метода запрещен - В статическом классе только статические методы, но static не может быть входом в программу - Мб сделать проверку на класс внутри main, но не успею +(* TODO: Access to non-static fields from static methods is prohibited + Static classes can only have static methods, but static cannot be the program entry point + Maybe add class check inside main, but won't have time *) let%expect_test "Main 2" = @@ -135,7 +135,7 @@ let%expect_test "Functions 1" = Result: '1' |}] ;; -(* TODO: не static нельзя *) +(* TODO: non static not allowed *) let%expect_test "Invalid value" = show_wrap diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index cd78b21b..c9bba6f4 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -147,7 +147,6 @@ let%expect_test "For" = Ok! |}] ;; -(* TODO: some stuff here! *) let%expect_test "Wrong main" = test_ast {| @@ -185,11 +184,11 @@ let%expect_test "Function type mismatch" = (TCError TypeMismatch) |}] ;; -(* TODO: occurs check: smth like +(* TODO: occurs check test: smth like {| class Program { - public void foo() { - bool a = new A(); + public void f() { + bool a = new Ob(); }; }|} *) From c1bda8e4639b89e4f42cbd94bad34c7b23e2b09d Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:06:57 +0300 Subject: [PATCH 46/84] fix: linter Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/typecheck_tests.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index c9bba6f4..d655ed52 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -147,7 +147,6 @@ let%expect_test "For" = Ok! |}] ;; - let%expect_test "Wrong main" = test_ast {| class Program { From 1e622b3771fd15d04fbeaf33e9b63d6b312380e9 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:14:47 +0300 Subject: [PATCH 47/84] fix: updated .opam file Signed-off-by: f1i3g3 --- .../{CSharpStrange.opam => CSharpStrange_Kuznetsov.opam} | 0 CSharpStrange_Kuznetsov/dune-project | 2 +- CSharpStrange_Kuznetsov/lib/dune | 2 +- CSharpStrange_Kuznetsov/tests/dune | 2 +- 4 files changed, 3 insertions(+), 3 deletions(-) rename CSharpStrange_Kuznetsov/{CSharpStrange.opam => CSharpStrange_Kuznetsov.opam} (100%) diff --git a/CSharpStrange_Kuznetsov/CSharpStrange.opam b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam similarity index 100% rename from CSharpStrange_Kuznetsov/CSharpStrange.opam rename to CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index d5a6b659..815c8f3f 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -15,7 +15,7 @@ (homepage "https://github.com/f1i3g3/fp25") (package - (name CSharpStrange) + (name CSharpStrange_Kuznetsov) (synopsis "An interpreter for strange subset of C# language") (description "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)") diff --git a/CSharpStrange_Kuznetsov/lib/dune b/CSharpStrange_Kuznetsov/lib/dune index e97b2f57..e8ad75aa 100644 --- a/CSharpStrange_Kuznetsov/lib/dune +++ b/CSharpStrange_Kuznetsov/lib/dune @@ -1,6 +1,6 @@ (library (name c_sharp_strange_lib) - (public_name CSharpStrange.Lib) + (public_name CSharpStrange_Kuznetsov.Lib) (modules Ast Parser Prettyprinter Typecheck Monads Common Interpret) (libraries angstrom base) (preprocess diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index fb245d54..1e150ae5 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -1,6 +1,6 @@ (library (name tests) - (public_name CSharpStrange.Lib.Tests) + (public_name CSharpStrange_Kuznetsov.Lib.Tests) (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests) (libraries angstrom c_sharp_strange_lib qcheck) (inline_tests) From fda0f9dab8acf4bb81c516d3849181102a11054d Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:19:44 +0300 Subject: [PATCH 48/84] fix: updated ocamlformat Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/.ocamlformat | 2 +- CSharpStrange_Kuznetsov/bin/REPL.ml | 4 +-- CSharpStrange_Kuznetsov/lib/parser.ml | 2 +- .../tests/interpret_tests.ml | 18 ++++++---- CSharpStrange_Kuznetsov/tests/parser_tests.ml | 8 +++-- .../tests/typecheck_tests.ml | 33 ++++++++++++------- 6 files changed, 44 insertions(+), 23 deletions(-) diff --git a/CSharpStrange_Kuznetsov/.ocamlformat b/CSharpStrange_Kuznetsov/.ocamlformat index 7fd0ea01..435021b6 100644 --- a/CSharpStrange_Kuznetsov/.ocamlformat +++ b/CSharpStrange_Kuznetsov/.ocamlformat @@ -1,2 +1,2 @@ profile=janestreet -version=0.26.2 \ No newline at end of file +version=0.27.0 \ No newline at end of file diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index beb20658..45f5655a 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -25,8 +25,8 @@ let () = ; "-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n" ] (fun _ -> - Stdlib.Format.eprintf "Something got wrong\n"; - Stdlib.exit 1) + Stdlib.Format.eprintf "Something got wrong\n"; + Stdlib.exit 1) "\n" in let path = diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index cfb85aa0..a0d71a21 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -252,7 +252,7 @@ let parse_for body = let p_for = lift2 (fun (f_init_p, f_cond_p, f_iter_p) f_body -> - SFor (f_init_p, f_cond_p, f_iter_p, f_body)) + SFor (f_init_p, f_cond_p, f_iter_p, f_body)) (parens @@ lift3 (fun init cond incr -> init, cond, incr) diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index f821d7f8..d98b26cc 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -35,7 +35,8 @@ let%expect_test "Main 1" = } } |}; - [%expect {| + [%expect + {| Result: '-58' |}] ;; @@ -59,7 +60,8 @@ let%expect_test "Main 2" = return res; } } |}; - [%expect {| + [%expect + {| Result: '870' |}] ;; @@ -92,7 +94,8 @@ let%expect_test "Main 3" = return 0; } } |}; - [%expect {| + [%expect + {| Result: '141' |}] ;; @@ -110,7 +113,8 @@ let%expect_test "Main 4" = return s; } } |}; - [%expect {| + [%expect + {| Result: '18' |}] ;; @@ -131,7 +135,8 @@ let%expect_test "Functions 1" = return is_right_triangle(3,4,5); } } |}; - [%expect {| + [%expect + {| Result: '1' |}] ;; @@ -147,6 +152,7 @@ let%expect_test "Invalid value" = return b; } } |}; - [%expect {| + [%expect + {| (IError (OtherError "Value is not initialized"))|}] ;; diff --git a/CSharpStrange_Kuznetsov/tests/parser_tests.ml b/CSharpStrange_Kuznetsov/tests/parser_tests.ml index f586e65b..268a19b4 100644 --- a/CSharpStrange_Kuznetsov/tests/parser_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/parser_tests.ml @@ -254,7 +254,9 @@ let%test "Parse method 1" = ;; let%test "Parse method 2" = - apply_parser parse_method_member {|public int Func() + apply_parser + parse_method_member + {|public int Func() { return 2; }|} @@ -308,7 +310,9 @@ let%test "Parse method 3" = ;; let%test "Parse class 1" = - apply_parser parse_class {| + apply_parser + parse_class + {| public class Sample {}|} = Ok (Class ([ MPublic ], Id "Sample", [])) ;; diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index d655ed52..2f0d7609 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -35,7 +35,8 @@ let%expect_test "Factorial" = return Fac(5); } } |}; - [%expect {| + [%expect + {| Ok! |}] ;; @@ -55,13 +56,15 @@ let%expect_test "Wrong factorial" = ;; let%expect_test "Already declared variable" = - test_ast {| + test_ast + {| class Program { int a = 5; int b = 9; int a = 9; } |}; - [%expect {| + [%expect + {| (TCError (OtherError "This variable is already declared")) |}] ;; @@ -81,19 +84,22 @@ let%expect_test "Checking fields" = r = s != "kkkk" && (190%22 == 100 * -2/5); } } |}; - [%expect {| + [%expect + {| Ok! |}] ;; (* TODO: parser check! *) let%expect_test "String + int" = - test_ast {| + test_ast + {| class Program { string a = "5"; int c = 9 + a; } |}; - [%expect {| + [%expect + {| (TCError TypeMismatch) |}] ;; @@ -120,7 +126,8 @@ let%expect_test "While" = } } } |}; - [%expect {| + [%expect + {| Ok! |}] ;; @@ -143,12 +150,14 @@ let%expect_test "For" = return count; } } |}; - [%expect {| + [%expect + {| Ok! |}] ;; let%expect_test "Wrong main" = - test_ast {| + test_ast + {| class Program { public async void Main() {} } @@ -167,7 +176,8 @@ let%expect_test "Already declared function" = int a = 9; void Test() {} } |}; - [%expect {| + [%expect + {| (TCError (OtherError "This variable is already declared")) |}] ;; @@ -179,7 +189,8 @@ let%expect_test "Function type mismatch" = return n+m; } }|}; - [%expect {| + [%expect + {| (TCError TypeMismatch) |}] ;; From 26d7eb12e7c1fc8a045baf0b127b9e712e2f8894 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:24:28 +0300 Subject: [PATCH 49/84] fix: fixed compiler warnings Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/interpret.ml | 11 ----------- CSharpStrange_Kuznetsov/lib/monads.mli | 2 -- CSharpStrange_Kuznetsov/lib/parser.ml | 1 - 3 files changed, 14 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index a3230281..1fbeab05 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -167,7 +167,6 @@ let alloc v store = loc, store ;; -let lookup_env_r (id : ident) (rt : runtime) = lookup_env id rt.env let lookup_store_r l rt = lookup_store l rt.store let update_store_r l v rt = { rt with store = update_store l v rt.store } @@ -192,16 +191,6 @@ let ident_of_vardecl = function | Var (_, id) -> id ;; -let expect_bool = function - | VBool b -> Ok b - | _ -> Error TypeMismatch -;; - -let expect_int = function - | VInt i -> Ok i - | _ -> Error TypeMismatch -;; - let add_var (id : ident) (loc : location) (env : env) = match env with | scope :: rest -> diff --git a/CSharpStrange_Kuznetsov/lib/monads.mli b/CSharpStrange_Kuznetsov/lib/monads.mli index d06e4fe0..05af80cf 100644 --- a/CSharpStrange_Kuznetsov/lib/monads.mli +++ b/CSharpStrange_Kuznetsov/lib/monads.mli @@ -47,7 +47,6 @@ module TYPECHECK : sig val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t val read_local : Common.obj_content IdMap.t t - val read_local_el : ident -> (Common.obj_content option -> 'a t) -> 'a t val read_local_el_opt : ident -> Common.obj_content option t val read_local_el : ident -> Common.obj_content t val write_local : Common.obj_content IdMap.t -> unit t @@ -55,7 +54,6 @@ module TYPECHECK : sig val write_meth_type_opt : _type option -> unit t val write_meth_type : _type -> unit t val read_global : Common.context IdMap.t t - val read_global_el : ident -> (Common.context option -> 'a t) -> 'a t val read_global_el_opt : ident -> Common.context option t val read_global_el : ident -> Common.context t val read_meth_type : _type option t diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index a0d71a21..4331ebb0 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -7,7 +7,6 @@ open Angstrom open Base (* Chain functions *) -let chainl0 expr op = op >>= (fun op1 -> expr >>| op1) <|> expr let chainl1 expr op = let rec pars e1 = lift2 (fun op1 e2 -> op1 e1 e2) op expr >>= pars <|> return e1 in From 637bcb1ee543d01e3a5c55f22777f8239cc7c449 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:30:02 +0300 Subject: [PATCH 50/84] fix: removed unused Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/typecheck.ml | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 2e6a2b88..fb7733d1 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -20,15 +20,9 @@ let vartype_to_type = function | TypeVar t -> t ;; -let vardecl_to_type = function - | Var (t, _) -> return (vartype_to_type t) -;; - let name_to_obj_ctx = read_local_el let eq f e1 e2 = if f e1 e2 then return e1 else fail (TCError TypeMismatch) let eq_type t1 t2 = eq equal__type t1 t2 -let eq_ident n1 n2 = eq equal_ident n1 n2 -let eq_ident_return_ctx n1 n2 m f = if equal_ident n1 n2 then Some (f m) else None let field_of_ast = function | VarField (mods, typ, id, init) -> @@ -78,10 +72,6 @@ let get_class_memb id memb = | _ -> None ;; -let get_class_name = function - | Class (_, id, _) -> id -;; - let find_memb_from_obj obj_id id = let find_memb b id f = List.find_map (f id) b in let find_class_memb b id = find_memb b id get_class_memb in @@ -99,17 +89,6 @@ let is_public obj_id ctx mds = is_m_list_public mds <|> (read_global_el obj_id >>= fun _ -> fail (TCError AccessError)) ;; -let find_obj_memb_with_fail n_obj n_mem = - find_memb_from_obj n_obj n_mem - >>= function - | Some memb -> - (match memb with - | TCField f -> is_public n_obj memb f.field_modifiers - | TCMethod m -> is_public n_obj memb m.method_modifiers - | _ -> fail (TCError (ImpossibleResult "Object can only have fields and methods"))) - | None -> fail (TCError (OtherError "Class member not found")) -;; - let find_memb_type = function | TCLocalVar v -> return (vartype_to_type v.var_type) | TCField f -> return (vartype_to_type f.field_type) From b01e006116c1e3204b526bd3025400f8e707df2b Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:33:16 +0300 Subject: [PATCH 51/84] fix: remove unused (again) Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/typecheck.ml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index fb7733d1..0237bdb5 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -80,15 +80,6 @@ let find_memb_from_obj obj_id id = | TCClass (Class (_, _, b)) -> find_class_memb b id |> return ;; -let is_public obj_id ctx mds = - let rec is_m_list_public = function - | [] -> return (Some ctx) - | MPublic :: _ -> return (Some ctx) - | _ :: xs -> is_m_list_public xs - in - is_m_list_public mds <|> (read_global_el obj_id >>= fun _ -> fail (TCError AccessError)) -;; - let find_memb_type = function | TCLocalVar v -> return (vartype_to_type v.var_type) | TCField f -> return (vartype_to_type f.field_type) From ae0268c8508686002dcb73106b5074aa193d24f6 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 6 Mar 2026 22:38:13 +0300 Subject: [PATCH 52/84] chore: added zanuda config Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/.zanuda | 1 + 1 file changed, 1 insertion(+) create mode 100644 CSharpStrange_Kuznetsov/.zanuda diff --git a/CSharpStrange_Kuznetsov/.zanuda b/CSharpStrange_Kuznetsov/.zanuda new file mode 100644 index 00000000..0f09b19b --- /dev/null +++ b/CSharpStrange_Kuznetsov/.zanuda @@ -0,0 +1 @@ +forward mutability_check ignore REPL.ml From 7249a11a868a20788037e576d668eff686cab6dc Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 00:59:04 +0300 Subject: [PATCH 53/84] chore: uploaded missing files Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/.gitignore | 6 + CSharpStrange_Kuznetsov/COPYING | 674 +++++++++++++++++++++++++ CSharpStrange_Kuznetsov/COPYING.CC0 | 121 +++++ CSharpStrange_Kuznetsov/COPYING.LESSER | 165 ++++++ CSharpStrange_Kuznetsov/Makefile | 49 ++ CSharpStrange_Kuznetsov/dune-project | 6 +- 6 files changed, 1018 insertions(+), 3 deletions(-) create mode 100644 CSharpStrange_Kuznetsov/.gitignore create mode 100644 CSharpStrange_Kuznetsov/COPYING create mode 100644 CSharpStrange_Kuznetsov/COPYING.CC0 create mode 100644 CSharpStrange_Kuznetsov/COPYING.LESSER create mode 100644 CSharpStrange_Kuznetsov/Makefile diff --git a/CSharpStrange_Kuznetsov/.gitignore b/CSharpStrange_Kuznetsov/.gitignore new file mode 100644 index 00000000..7102a822 --- /dev/null +++ b/CSharpStrange_Kuznetsov/.gitignore @@ -0,0 +1,6 @@ +_build +_coverage +/_esy +/node_modules +/esy.lock +/.melange.eobjs diff --git a/CSharpStrange_Kuznetsov/COPYING b/CSharpStrange_Kuznetsov/COPYING new file mode 100644 index 00000000..f288702d --- /dev/null +++ b/CSharpStrange_Kuznetsov/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/CSharpStrange_Kuznetsov/COPYING.CC0 b/CSharpStrange_Kuznetsov/COPYING.CC0 new file mode 100644 index 00000000..0e259d42 --- /dev/null +++ b/CSharpStrange_Kuznetsov/COPYING.CC0 @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/CSharpStrange_Kuznetsov/COPYING.LESSER b/CSharpStrange_Kuznetsov/COPYING.LESSER new file mode 100644 index 00000000..0a041280 --- /dev/null +++ b/CSharpStrange_Kuznetsov/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/CSharpStrange_Kuznetsov/Makefile b/CSharpStrange_Kuznetsov/Makefile new file mode 100644 index 00000000..e234db4b --- /dev/null +++ b/CSharpStrange_Kuznetsov/Makefile @@ -0,0 +1,49 @@ +.PHONY: repl tests test fmt lint celan + +all: + dune build + +repl: + dune build ./REPL.exe && rlwrap _build/default/REPL.exe + +tests: test +test: + dune runtest + +celan: clean +clean: + @$(RM) -r _build _coverage + +fmt: + dune build @fmt --auto-promote + +lint: + dune build @lint --force + +release: + dune build --profile=release + dune runtest --profile=release + +install: + dune b @install --profile=release + dune install + +ODIG_SWITCHES = --odoc-theme=odig.gruvbox.light +ODIG_SWITCHES += --no-tag-index +ODIG_SWITCHES += --no-pkg-deps +odig: + odig odoc $(ODIG_SWITCHES) Lambda + +TEST_COV_D = /tmp/cov +COVERAGE_OPTS = --coverage-path $(TEST_COV_D) --expect lib/ --expect tests/ + +.PHONY: test_coverage coverage +test_coverage: coverage +coverage: + $(RM) -r $(TEST_COV_D) + mkdir -p $(TEST_COV_D) + BISECT_FILE=$(TEST_COV_D)/language dune runtest --no-print-directory \ + --instrument-with bisect_ppx --force + bisect-ppx-report html $(COVERAGE_OPTS) + bisect-ppx-report summary $(COVERAGE_OPTS) + @echo "Use 'xdg-open _coverage/index.html' to see coverage report" diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index 815c8f3f..4f328d98 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -10,16 +10,16 @@ (maintainers "Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com") -(bug_reports "https://github.com/f1i3g3/fp25") +(bug_reports "https://github.com/Kakadu/fp25") -(homepage "https://github.com/f1i3g3/fp25") +(homepage "https://github.com/Kakadu/fp25") (package (name CSharpStrange_Kuznetsov) (synopsis "An interpreter for strange subset of C# language") (description "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)") - ; TODO: actual documentation (documentation "https://kakadu.github.io/fp2024/docs/Lambda") + (documentation "https://kakadu.github.io/fp25/docs/CSharpStrange_Kuznetsov") (version 0.2) (depends dune From 4e7d44daff5feffb07b1d3cf59751e35ee6d5a58 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 01:29:12 +0300 Subject: [PATCH 54/84] chore: .opam updated Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam index d534b6a7..7dd3f1e4 100644 --- a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam +++ b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam @@ -7,8 +7,9 @@ description: maintainer: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] authors: ["Dmitrii Kuznetsov dmitrvlkuznetsov@gmail.com"] license: "LGPL-3.0-or-later" -homepage: "https://github.com/f1i3g3/fp25" -bug-reports: "https://github.com/f1i3g3/fp25" +homepage: "https://github.com/Kakadu/fp25" +doc: "https://kakadu.github.io/fp25/docs/CSharpStrange_Kuznetsov" +bug-reports: "https://github.com/Kakadu/fp25" depends: [ "dune" {>= "3.7"} "angstrom" From 47a73922e95c037e250b7fe55f226276fbfad5c5 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 01:29:32 +0300 Subject: [PATCH 55/84] fix: made zanuda happier Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/common.ml | 5 +--- CSharpStrange_Kuznetsov/lib/common.mli | 12 ---------- CSharpStrange_Kuznetsov/lib/interpret.ml | 22 +++++++++--------- CSharpStrange_Kuznetsov/lib/monads.ml | 2 +- CSharpStrange_Kuznetsov/lib/parser.ml | 2 +- CSharpStrange_Kuznetsov/lib/typecheck.ml | 29 ++++++++++++++---------- 6 files changed, 31 insertions(+), 41 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/common.ml b/CSharpStrange_Kuznetsov/lib/common.ml index 736aba41..f41c9660 100644 --- a/CSharpStrange_Kuznetsov/lib/common.ml +++ b/CSharpStrange_Kuznetsov/lib/common.ml @@ -48,7 +48,7 @@ module AdrMap = Map.Make (Adr) type var_info = { var_type : var_type - ; initialized : bool (* TODO: ?? *) + ; initialized : bool } [@@deriving show { with_path = false }, eq] @@ -59,7 +59,6 @@ type field_info = ; field_init : expr option ; is_static : bool } -[@@deriving show { with_path = false }, eq] type method_info = { method_modifiers : modifier list @@ -70,13 +69,11 @@ type method_info = ; is_static : bool ; is_main : bool } -[@@deriving show { with_path = false }, eq] type obj_content = | TCLocalVar of var_info | TCField of field_info | TCMethod of method_info -[@@deriving show { with_path = false }, eq] type context = TCClass of c_sharp_class diff --git a/CSharpStrange_Kuznetsov/lib/common.mli b/CSharpStrange_Kuznetsov/lib/common.mli index 7f1bf59c..fb59f83e 100644 --- a/CSharpStrange_Kuznetsov/lib/common.mli +++ b/CSharpStrange_Kuznetsov/lib/common.mli @@ -86,10 +86,6 @@ type field_info = ; is_static : bool } -val pp_field_info : Format.formatter -> field_info -> unit -val show_field_info : field_info -> string -val equal_field_info : field_info -> field_info -> bool - (* Method information for type checker *) type method_info = { method_modifiers : modifier list @@ -101,20 +97,12 @@ type method_info = ; is_main : bool (** Whether this is the Main method *) } -val pp_method_info : Format.formatter -> method_info -> unit -val show_method_info : method_info -> string -val equal_method_info : method_info -> method_info -> bool - (* Type checker content types *) type obj_content = | TCLocalVar of var_info (** Local variable *) | TCField of field_info (** Class field *) | TCMethod of method_info (** Class method *) -val pp_obj_content : Format.formatter -> obj_content -> unit -val show_obj_content : obj_content -> string -val equal_obj_content : obj_content -> obj_content -> bool - (**Global context for type checker *) type context = TCClass of c_sharp_class diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 1fbeab05..99cc5c60 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -113,7 +113,7 @@ let empty_runtime = let string_of_ident (Id s) = s let rec lookup_env id = function - | [] -> Error (NoVariable ("variable not found: " ^ string_of_ident id)) + | [] -> Error (NoVariable ("Variable not found: " ^ string_of_ident id)) | scope :: rest -> (match IdMap.find_opt id scope with | Some var_info -> Ok var_info.loc @@ -203,7 +203,7 @@ let push_scope env = Ok (IdMap.empty :: env) let pop_scope = function | _ :: rest -> Ok rest - | [] -> Error (OtherError "cannot pop scope") + | [] -> Error (OtherError "Cannot pop scope") ;; let var_field_of_ast = function @@ -235,11 +235,11 @@ let class_of_ast (Class (_, _, fields)) = let find_field obj_id field_id rt = match List.find_opt (fun o -> o.obj_id = obj_id) rt.objects with - | None -> Error (OtherError "object not found") + | None -> Error (OtherError "Object not found") | Some obj -> (match List.find_opt (fun (id, _) -> id = field_id) obj.fields with | Some (_, v) -> Ok v - | None -> Error (OtherError "field not found")) + | None -> Error (OtherError "Field not found")) ;; let update_field obj_id field_id new_value rt = @@ -309,7 +309,7 @@ let rec eval_expr (rt : runtime) = function return (v, rt2) | Error _ -> (match rt1.curr_object with - | None -> Error (OtherError ("cannot assign to " ^ string_of_ident id)) + | None -> Error (OtherError ("Cannot assign to " ^ string_of_ident id)) | Some obj_id -> let rt2 = update_field obj_id id v rt1 in return (v, rt2)))) @@ -352,7 +352,7 @@ let rec eval_expr (rt : runtime) = function (match fn_expr with | EId id -> (match lookup_func_opt id rt.fenv with - | None -> Error (OtherError ("function not found: " ^ string_of_ident id)) + | None -> Error (OtherError ("Function not found: " ^ string_of_ident id)) | Some f -> let rec eval_args rt = function | [] -> return ([], rt) @@ -364,7 +364,7 @@ let rec eval_expr (rt : runtime) = function let* arg_vals, rt2 = eval_args rt args in let* v, rt3 = call_function rt2 f arg_vals in return (v, rt3)) - | _ -> Error (OtherError "invalid function call")) + | _ -> Error (OtherError "Invalid function call")) | EArrayAccess _ -> Error NotImplemented | EAwait _ -> Error NotImplemented @@ -399,10 +399,10 @@ and call_function (rt : runtime) f args = let* env2 = match env with | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) - | [] -> Error (OtherError "empty environment in bind_params") + | [] -> Error (OtherError "Empty environment in bind_params") in bind_params env2 ps vs rt1 - | _ -> Error (OtherError "argument mismatch") + | _ -> Error (OtherError "Argument mismatch") in let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in let rt_with_this = { rt_func with curr_object = caller_obj } in @@ -411,7 +411,7 @@ and call_function (rt : runtime) f args = match flow with | Return v -> return (v, restored_rt) | Normal -> return (VNull, restored_rt) - | Break | Continue -> Error (OtherError "break/continue outside loop") + | Break | Continue -> Error (OtherError "Break/continue outside loop") and exec_stmt (rt : runtime) = function | SExpr e -> @@ -480,7 +480,7 @@ and exec_stmt (rt : runtime) = function let* rt1, r = exec_stmt rt0 s in (match r with | Normal -> return rt1 - | _ -> Error (OtherError "invalid control flow in for init")) + | _ -> Error (OtherError "Invalid control flow in for init")) in let rec loop rt = let* cond_val, rt1 = diff --git a/CSharpStrange_Kuznetsov/lib/monads.ml b/CSharpStrange_Kuznetsov/lib/monads.ml index 9f1fc1d1..0d2133ad 100644 --- a/CSharpStrange_Kuznetsov/lib/monads.ml +++ b/CSharpStrange_Kuznetsov/lib/monads.ml @@ -63,7 +63,7 @@ module STATEERROR = struct ;; (*('st, 'a) t -> 'st -> 'st * ('a, error) Result.t *) - let run f st = f st + let run f = f end module TYPECHECK = struct diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index 4331ebb0..05fe416e 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -192,7 +192,7 @@ let parse_ops = let lv2 = many (choice [ ( ^!^ ); ( ^!-^ ) ]) >>= fun ops -> - let appl op acc = op acc in + let appl op = op in lv1 >>= fun e -> return (List.fold_right ops ~f:appl ~init:e) in (* TODO: rewrite somehow + more ops *) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 0237bdb5..ee491e49 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -339,19 +339,24 @@ let tc_member mem class_fields = let m = method_of_ast (Method (mds, tp, id, pms, b)) in if m.is_main then ( - let handle_main = - match mds, pms, tp with - | [ MStatic ], Params [], TypeBase TypeInt | [ MStatic ], Params [], TypeVoid -> - tc_meth tp (Params []) b class_fields *> read_main_class - >>= (function - | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) - | Some _ -> fail (TCError (OtherError "Main method already exists"))) - | _, _, _ -> - fail - (TCError - (OtherError "Main must be static, non-async, no params, return int/void")) + let is_valid_signature = + mds = [ MStatic ] + && pms = Params [] + && + match tp with + | TypeBase TypeInt | TypeVoid -> true + | _ -> false in - handle_main) + if is_valid_signature + then + tc_meth tp (Params []) b class_fields *> read_main_class + >>= function + | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) + | Some _ -> fail (TCError (OtherError "Main method already exists")) + else + fail + (TCError + (OtherError "Main must be static, non-async, no params, return int/void"))) else tc_meth tp pms b class_fields in match mem with From 4e1e90babd9fd12e4f44283ecb2d7d0bb003c42c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 01:40:38 +0300 Subject: [PATCH 56/84] fix: removed failwith Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/interpret.ml | 4 +- CSharpStrange_Kuznetsov/lib/typecheck.ml | 102 +++++++++++++---------- 2 files changed, 60 insertions(+), 46 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 99cc5c60..c092fc1c 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -619,10 +619,10 @@ let interpret str = (* TODO: error messages? *) (* +Quicktests for parser TODO: lambdas + closures arrays (1D) + new - FIX BUGS (interpreter) - Quicktests for parser (if time permits) + pre/post increment/decrement LINQ (simple array queries) async/await (at least without lambdas) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index ee491e49..74e7939a 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -33,15 +33,18 @@ let field_of_ast = function | _ -> false) mods in - { field_modifiers = mods - ; field_type = typ - ; field_name = id - ; field_init = init - ; is_static - } - | Method _ -> failwith "Expected field, got method" (* TODO *) + Ok + { field_modifiers = mods + ; field_type = typ + ; field_name = id + ; field_init = init + ; is_static + } + | Method _ -> Error (TCError TypeMismatch) ;; +(* Expected field, got method *) + let method_of_ast = function | Ast.Method (mods, ret_type, id, pms, body) -> let is_static = @@ -52,23 +55,30 @@ let method_of_ast = function mods in let is_main = equal_ident id (Id "Main") in - { method_modifiers = mods - ; method_return = ret_type - ; method_name = id - ; method_params = pms - ; method_body = body - ; is_static - ; is_main - } - | Ast.VarField _ -> failwith "Expected method, got field" (* TODO *) + Ok + { method_modifiers = mods + ; method_return = ret_type + ; method_name = id + ; method_params = pms + ; method_body = body + ; is_static + ; is_main + } + | Ast.VarField _ -> Error (TCError TypeMismatch) ;; +(* Expected method, got field *) + let get_class_memb id memb = match memb with | VarField (_, _, f_id, _) when equal_ident f_id id -> - Some (TCField (field_of_ast memb)) + (match field_of_ast memb with + | Ok f_info -> Some (TCField f_info) + | Error _ -> None) | Method (_, _, m_id, _, _) when equal_ident m_id id -> - Some (TCMethod (method_of_ast memb)) + (match method_of_ast memb with + | Ok m_info -> Some (TCMethod m_info) + | Error _ -> None) | _ -> None ;; @@ -336,28 +346,30 @@ let tc_member mem class_fields = *> typecheck_stmt body) in let tc_class_method (mds, tp, id, pms, b) class_fields = - let m = method_of_ast (Method (mds, tp, id, pms, b)) in - if m.is_main - then ( - let is_valid_signature = - mds = [ MStatic ] - && pms = Params [] - && - match tp with - | TypeBase TypeInt | TypeVoid -> true - | _ -> false - in - if is_valid_signature - then - tc_meth tp (Params []) b class_fields *> read_main_class - >>= function - | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) - | Some _ -> fail (TCError (OtherError "Main method already exists")) - else - fail - (TCError - (OtherError "Main must be static, non-async, no params, return int/void"))) - else tc_meth tp pms b class_fields + match method_of_ast (Method (mds, tp, id, pms, b)) with + | Ok m -> + if m.is_main + then ( + let is_valid_signature = + mds = [ MStatic ] + && pms = Params [] + && + match tp with + | TypeBase TypeInt | TypeVoid -> true + | _ -> false + in + if is_valid_signature + then + tc_meth tp (Params []) b class_fields *> read_main_class + >>= function + | None -> get_curr_class_name >>= fun n -> write_main_class (Some n) + | Some _ -> fail (TCError (OtherError "Main method already exists")) + else + fail + (TCError + (OtherError "Main must be static, non-async, no params, return int/void"))) + else tc_meth tp pms b class_fields + | Error e -> fail e in match mem with | VarField (_, tp, _, e_opt) -> tc_class_field tp e_opt @@ -378,11 +390,13 @@ let typecheck_obj cl = let f mem = match mem with | VarField (_, _, id, _) -> - let field_info = field_of_ast mem in - save_decl id (TCField field_info) + (match field_of_ast mem with + | Ok field_info -> save_decl id (TCField field_info) + | Error e -> fail e) | Method (_, _, id, _, _) -> - let method_info = method_of_ast mem in - save_decl id (TCMethod method_info) + (match method_of_ast mem with + | Ok method_info -> save_decl id (TCMethod method_info) + | Error e -> fail e) in iter f fields in From 0f69a7ad433380a26f54cca1c72071e0fcd15a51 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 02:14:54 +0300 Subject: [PATCH 57/84] fix: added REPL.mli Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.mli | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 CSharpStrange_Kuznetsov/bin/REPL.mli diff --git a/CSharpStrange_Kuznetsov/bin/REPL.mli b/CSharpStrange_Kuznetsov/bin/REPL.mli new file mode 100644 index 00000000..6b453b16 --- /dev/null +++ b/CSharpStrange_Kuznetsov/bin/REPL.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 6cc855995e10213926113f1d6335e9fee843571b Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 02:31:15 +0300 Subject: [PATCH 58/84] refator: some renaming Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/interpret.ml | 4 -- CSharpStrange_Kuznetsov/lib/typecheck.ml | 91 +++++++++--------------- 2 files changed, 35 insertions(+), 60 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index c092fc1c..d8ed0fea 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -183,10 +183,6 @@ let value_of_val_type = function | ValNull -> VNull ;; -let string_of_ident = function - | Id s -> s -;; - let ident_of_vardecl = function | Var (_, id) -> id ;; diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 74e7939a..56b50714 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -96,30 +96,9 @@ let find_memb_type = function | TCMethod m -> return m.method_return ;; -let typecheck_method_args (Params params) (Args args) expr_tc = - let params_to_list_of_type p = - List.map - (function - | Var (t, _) -> vartype_to_type t) - p - in - let args_to_list_of_type a = map (fun x -> expr_tc x >>= find_memb_type) a in - let compare_two_lists l1 l2 eq rez = - match List.compare_lengths l1 l2 with - | 0 -> - if List.equal eq l1 l2 - then return rez - else fail (TCError (OtherError "Method invocation check error")) - | _ -> fail (TCError (OtherError "Method invocation check error")) - in - args_to_list_of_type args - >>= fun args -> - compare_two_lists (params_to_list_of_type params) args equal__type params -;; - let find_expr_type e expr_tc = expr_tc e >>= find_memb_type -let typecheck_bin_op b e1 e2 expr_tc = +let tc_bin_op b e1 e2 expr_tc = let compare_two_expr_type e1 e2 = find_expr_type e1 expr_tc >>= fun e1 -> find_expr_type e2 expr_tc >>= fun e2 -> eq_type e1 e2 @@ -143,7 +122,7 @@ let typecheck_bin_op b e1 e2 expr_tc = find_expr_type e1 expr_tc >>= fun e -> compare_two_expr_type e1 e2 *> return_rez e ;; -let typecheck_un_op u e expr_tc = +let tc_un_op u e expr_tc = let tc_un_op u e = find_expr_type e expr_tc >>= fun t -> @@ -204,7 +183,7 @@ let check_initialized n = | TCMethod _ -> return () ;; -let typecheck_expr = +let tc_expr = let rec tc_expr_ = function | EId n -> name_to_obj_ctx n @@ -220,15 +199,15 @@ let typecheck_expr = let var_info = { var_type = TypeVar (value_to_type v); initialized = true } in return (TCLocalVar var_info) | EFuncCall (e, args) -> tc_method_invoke e args tc_expr_ - | EBinOp (b, e1, e2) -> typecheck_bin_op b e1 e2 tc_expr_ - | EUnOp (u, e) -> typecheck_un_op u e tc_expr_ + | EBinOp (b, e1, e2) -> tc_bin_op b e1 e2 tc_expr_ + | EUnOp (u, e) -> tc_un_op u e tc_expr_ | _ -> fail (TCError NotImplemented) in tc_expr_ ;; -let typecheck_expr_with_type e = typecheck_expr e >>= find_memb_type -let eq_type_with_expr t e = typecheck_expr_with_type e >>= fun e_t -> eq_type e_t t +let tc_expr_with_type e = tc_expr e >>= find_memb_type +let eq_type_with_expr t e = tc_expr_with_type e >>= fun e_t -> eq_type e_t t let save_decl n ctx = read_local_el_opt n @@ -239,20 +218,20 @@ let save_decl n ctx = let apply_local f = read_local >>= fun old_l -> f *> write_local old_l -let rec typecheck_stmt = +let rec tc_stmt = let is_expr_bool e = - typecheck_expr_with_type e >>= fun t -> eq_type t (TypeBase TypeBool) + tc_expr_with_type e >>= fun t -> eq_type t (TypeBase TypeBool) in - let typecheck_stmt_expr expr = + let tc_stmt_expr expr = match expr with | EFuncCall (e, args) -> - typecheck_expr e + tc_expr e >>= (function | TCMethod { method_return = TypeVoid; method_params = pms; _ } -> - typecheck_method_args pms args typecheck_expr *> return () + tc_method_args pms args tc_expr *> return () | TCMethod _ -> fail (TCError TypeMismatch) | _ -> fail (TCError TypeMismatch)) - | EBinOp (OpAssign, _, _) -> typecheck_expr expr *> return () + | EBinOp (OpAssign, _, _) -> tc_expr expr *> return () | _ -> fail (TCError TypeMismatch) in let save_decl n t initialized = @@ -263,11 +242,11 @@ let rec typecheck_stmt = write_local_el n (TCLocalVar var_info) | Some _ -> fail (TCError (OtherError "This variable is already declared")) in - let typecheck_decl t n = function + let tc_decl t n = function | Some e -> eq_type_with_expr t e *> save_decl n t true *> return () | None -> save_decl n t false *> return () in - let typecheck_return e_opt = + let tc_return e_opt = read_meth_type >>= fun m_t -> match m_t, e_opt with @@ -282,33 +261,33 @@ let rec typecheck_stmt = | None -> return () | Some s -> f s *> return () in - let typecheck_for_state init cond iter = - let typecheck_init = function + let tc_for_state init cond iter = + let tc_init = function | None -> return () - | Some (SDecl (Var (TypeVar t, n), e)) -> typecheck_decl t n e + | Some (SDecl (Var (TypeVar t, n), e)) -> tc_decl t n e | _ -> fail (TCError TypeMismatch) in - let typecheck_cond = opt_unpack is_expr_bool cond in - let typecheck_iter = opt_unpack typecheck_stmt_expr iter in - lift3 (fun _ _ _ -> ()) (typecheck_init init) typecheck_cond typecheck_iter + let tc_cond = opt_unpack is_expr_bool cond in + let tc_iter = opt_unpack tc_stmt_expr iter in + lift3 (fun _ _ _ -> ()) (tc_init init) tc_cond tc_iter in - let typecheck_if_state cond b s_opt tc_st = - let typecheck_cond = is_expr_bool cond in - let typecheck_state = function + let tc_if_state cond b s_opt tc_st = + let tc_cond = is_expr_bool cond in + let tc_state = function | Some st -> tc_st st | None -> return () in - lift3 (fun _ _ _ -> ()) typecheck_cond (tc_st b) (typecheck_state s_opt) + lift3 (fun _ _ _ -> ()) tc_cond (tc_st b) (tc_state s_opt) in function - | SExpr expr -> typecheck_stmt_expr expr - | SDecl (Var (TypeVar t, n), e) -> typecheck_decl t n e - | SReturn e -> typecheck_return e - | SWhile (e, s) -> apply_local (is_expr_bool e *> typecheck_stmt s) + | SExpr expr -> tc_stmt_expr expr + | SDecl (Var (TypeVar t, n), e) -> tc_decl t n e + | SReturn e -> tc_return e + | SWhile (e, s) -> apply_local (is_expr_bool e *> tc_stmt s) | SFor (init, cond, iter, b) -> - apply_local (typecheck_for_state init cond iter *> typecheck_stmt b) - | SIf (e, b, s_opt) -> apply_local (typecheck_if_state e b s_opt typecheck_stmt) - | SBlock st_l -> apply_local (iter typecheck_stmt st_l) + apply_local (tc_for_state init cond iter *> tc_stmt b) + | SIf (e, b, s_opt) -> apply_local (tc_if_state e b s_opt tc_stmt) + | SBlock st_l -> apply_local (iter tc_stmt st_l) | SBreak | SContinue -> fail (TCError NotImplemented) ;; @@ -343,7 +322,7 @@ let tc_member mem class_fields = iter add_field_to_env class_fields *> write_meth_type typ *> save_params_to_l params - *> typecheck_stmt body) + *> tc_stmt body) in let tc_class_method (mds, tp, id, pms, b) class_fields = match method_of_ast (Method (mds, tp, id, pms, b)) with @@ -383,7 +362,7 @@ let save_global id ctx = | Some _ -> fail (TCError (OtherError "This variable is already declared")) ;; -let typecheck_obj cl = +let tc_obj cl = match cl with | Class (_, id, fields) -> let write_mems () = @@ -408,5 +387,5 @@ let typecheck_obj cl = *> return () ;; -let typecheck prog = run (typecheck_obj prog) (IdMap.empty, IdMap.empty, None, None, None) +let typecheck prog = run (tc_obj prog) (IdMap.empty, IdMap.empty, None, None, None) let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res From bd0f0a9d81b208a8353bae2420181d186985c0b2 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 02:56:59 +0300 Subject: [PATCH 59/84] style: typecheck Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/typecheck.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 56b50714..488f741b 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -219,9 +219,7 @@ let save_decl n ctx = let apply_local f = read_local >>= fun old_l -> f *> write_local old_l let rec tc_stmt = - let is_expr_bool e = - tc_expr_with_type e >>= fun t -> eq_type t (TypeBase TypeBool) - in + let is_expr_bool e = tc_expr_with_type e >>= fun t -> eq_type t (TypeBase TypeBool) in let tc_stmt_expr expr = match expr with | EFuncCall (e, args) -> @@ -284,13 +282,14 @@ let rec tc_stmt = | SDecl (Var (TypeVar t, n), e) -> tc_decl t n e | SReturn e -> tc_return e | SWhile (e, s) -> apply_local (is_expr_bool e *> tc_stmt s) - | SFor (init, cond, iter, b) -> - apply_local (tc_for_state init cond iter *> tc_stmt b) + | SFor (init, cond, iter, b) -> apply_local (tc_for_state init cond iter *> tc_stmt b) | SIf (e, b, s_opt) -> apply_local (tc_if_state e b s_opt tc_stmt) | SBlock st_l -> apply_local (iter tc_stmt st_l) | SBreak | SContinue -> fail (TCError NotImplemented) ;; +(* TODO Break TC *) + let tc_member mem class_fields = let tc_class_field f_type = function | Some e -> eq_type_with_expr (vartype_to_type f_type) e *> return () @@ -389,3 +388,5 @@ let tc_obj cl = let typecheck prog = run (tc_obj prog) (IdMap.empty, IdMap.empty, None, None, None) let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res + +(* TODO: unify with interpret *) From b906092e63f71424cdc842e9b89c4616426dcf5e Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 09:57:49 +0300 Subject: [PATCH 60/84] fix: some improvements Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 2 +- CSharpStrange_Kuznetsov/lib/common.ml | 4 +- CSharpStrange_Kuznetsov/lib/common.mli | 20 ++-- CSharpStrange_Kuznetsov/lib/interpret.ml | 101 ++++++++---------- CSharpStrange_Kuznetsov/lib/interpret.mli | 19 +--- .../tests/interpret_tests.ml | 3 +- 6 files changed, 62 insertions(+), 87 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 45f5655a..5347f90c 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -42,6 +42,6 @@ let () = match interpret_program ast with | Ok (Some v) -> printf "Result: %s\n" (show_value v) | Ok None -> printf "Result: void\n" - | Error _ -> failwith (sprintf "Interpretation error: %s" "TODO")) + | Error _ -> failwith (sprintf "Interpretation error")) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) ;; diff --git a/CSharpStrange_Kuznetsov/lib/common.ml b/CSharpStrange_Kuznetsov/lib/common.ml index f41c9660..f04dff35 100644 --- a/CSharpStrange_Kuznetsov/lib/common.ml +++ b/CSharpStrange_Kuznetsov/lib/common.ml @@ -46,7 +46,7 @@ end module AdrMap = Map.Make (Adr) -type var_info = +type tc_var_info = { var_type : var_type ; initialized : bool } @@ -71,7 +71,7 @@ type method_info = } type obj_content = - | TCLocalVar of var_info + | TCLocalVar of tc_var_info | TCField of field_info | TCMethod of method_info diff --git a/CSharpStrange_Kuznetsov/lib/common.mli b/CSharpStrange_Kuznetsov/lib/common.mli index fb59f83e..62f0fe67 100644 --- a/CSharpStrange_Kuznetsov/lib/common.mli +++ b/CSharpStrange_Kuznetsov/lib/common.mli @@ -68,14 +68,14 @@ module AdrMap : sig end (* Variable information for type checker *) -type var_info = +type tc_var_info = { var_type : var_type - ; initialized : bool (** Whether the variable has been initialized *) + ; initialized : bool (* Whether the variable has been initialized *) } -val pp_var_info : Format.formatter -> var_info -> unit -val show_var_info : var_info -> string -val equal_var_info : var_info -> var_info -> bool +val pp_tc_var_info : Format.formatter -> tc_var_info -> unit +val show_tc_var_info : tc_var_info -> string +val equal_tc_var_info : tc_var_info -> tc_var_info -> bool (* Field information for type checker *) type field_info = @@ -94,16 +94,16 @@ type method_info = ; method_params : params ; method_body : stmt ; is_static : bool - ; is_main : bool (** Whether this is the Main method *) + ; is_main : bool (* Whether this is the Main method *) } (* Type checker content types *) type obj_content = - | TCLocalVar of var_info (** Local variable *) - | TCField of field_info (** Class field *) - | TCMethod of method_info (** Class method *) + | TCLocalVar of tc_var_info (* Local variable *) + | TCField of field_info (* Class field *) + | TCMethod of method_info (* Class method *) -(**Global context for type checker *) +(* Global context for type checker *) type context = TCClass of c_sharp_class (* Type checker state module *) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index d8ed0fea..7b77c2f4 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -4,23 +4,11 @@ open Ast open Parser - -type interpret_error = - | NotImplemented - | NoVariable of string - | AddressNotFound of int - | VarDeclared of string - | TypeMismatch - | ImpossibleResult of string - | OtherError of string -[@@deriving show { with_path = false }] - -type error = IError of interpret_error [@@deriving show { with_path = false }] +open Common let ( let* ) = Result.bind let return x = Ok x -type 'a res = ('a, interpret_error) result type adr = Adr of int [@@deriving show { with_path = false }] module IdMap = Map.Make (struct @@ -47,12 +35,12 @@ type func = type location = int -type var_info = +type rt_var_info = { loc : location ; initialized : bool } -type env = var_info IdMap.t list +type env = rt_var_info IdMap.t list type func_env = (ident * func) list type store = @@ -113,22 +101,22 @@ let empty_runtime = let string_of_ident (Id s) = s let rec lookup_env id = function - | [] -> Error (NoVariable ("Variable not found: " ^ string_of_ident id)) + | [] -> Error (IError (NoVariable ("Variable not found: " ^ string_of_ident id))) | scope :: rest -> (match IdMap.find_opt id scope with | Some var_info -> Ok var_info.loc | None -> lookup_env id rest) ;; -let check_initialized id env = +let check_initialized id (env : env) = let rec find_var = function - | [] -> Error (NoVariable (string_of_ident id)) + | [] -> Error (IError (NoVariable (string_of_ident id))) | scope :: rest -> (match IdMap.find_opt id scope with - | Some var_info -> + | Some (var_info : rt_var_info) -> if var_info.initialized then Ok () - else Error (OtherError "Value is not initialized") + else Error (IError (OtherError "Value is not initialized")) | None -> find_var rest) in find_var env @@ -139,7 +127,7 @@ let mark_initialized id env = | [] -> [] | scope :: rest -> (match IdMap.find_opt id scope with - | Some var_info -> + | Some (var_info : rt_var_info) -> let new_var_info = { var_info with initialized = true } in IdMap.add id new_var_info scope :: rest | None -> scope :: mark_in_scope rest) @@ -156,7 +144,7 @@ let rec lookup_func_opt (id : ident) = function let lookup_store l store = match LocMap.find_opt l store.mem with | Some v -> Ok v - | None -> Error (AddressNotFound l) + | None -> Error (IError (AddressNotFound l)) ;; let update_store l v store = { store with mem = LocMap.add l v store.mem } @@ -192,14 +180,14 @@ let add_var (id : ident) (loc : location) (env : env) = | scope :: rest -> let var_info = { loc; initialized = false } in Ok (IdMap.add id var_info scope :: rest) - | [] -> Error (VarDeclared (string_of_ident id)) + | [] -> Error (IError (VarDeclared (string_of_ident id))) ;; let push_scope env = Ok (IdMap.empty :: env) let pop_scope = function | _ :: rest -> Ok rest - | [] -> Error (OtherError "Cannot pop scope") + | [] -> Error (IError (OtherError "Cannot pop scope")) ;; let var_field_of_ast = function @@ -231,11 +219,11 @@ let class_of_ast (Class (_, _, fields)) = let find_field obj_id field_id rt = match List.find_opt (fun o -> o.obj_id = obj_id) rt.objects with - | None -> Error (OtherError "Object not found") + | None -> Error (IError (OtherError "Object not found")) | Some obj -> (match List.find_opt (fun (id, _) -> id = field_id) obj.fields with | Some (_, v) -> Ok v - | None -> Error (OtherError "Field not found")) + | None -> Error (IError (OtherError "Field not found"))) ;; let update_field obj_id field_id new_value rt = @@ -283,7 +271,7 @@ let rec eval_expr (rt : runtime) = function | Ok v -> return (v, rt) | Error _ -> (match rt.curr_object with - | None -> Error (NoVariable (string_of_ident id)) + | None -> Error (IError (NoVariable (string_of_ident id))) | Some obj_id -> (match find_field obj_id id rt with | Ok v -> return (v, rt) @@ -305,11 +293,12 @@ let rec eval_expr (rt : runtime) = function return (v, rt2) | Error _ -> (match rt1.curr_object with - | None -> Error (OtherError ("Cannot assign to " ^ string_of_ident id)) + | None -> + Error (IError (OtherError ("Cannot assign to " ^ string_of_ident id))) | Some obj_id -> let rt2 = update_field obj_id id v rt1 in return (v, rt2)))) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) | EBinOp (OpAnd, e1, e2) -> let* v1, rt1 = eval_expr rt e1 in (match v1 with @@ -318,8 +307,8 @@ let rec eval_expr (rt : runtime) = function let* v2, rt2 = eval_expr rt1 e2 in (match v2 with | VBool b -> return (VBool b, rt2) - | _ -> Error TypeMismatch) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) + | _ -> Error (IError TypeMismatch)) | EBinOp (OpOr, e1, e2) -> let* v1, rt1 = eval_expr rt e1 in (match v1 with @@ -328,8 +317,8 @@ let rec eval_expr (rt : runtime) = function let* v2, rt2 = eval_expr rt1 e2 in (match v2 with | VBool b -> return (VBool b, rt2) - | _ -> Error TypeMismatch) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) + | _ -> Error (IError TypeMismatch)) | EBinOp (op, e1, e2) -> let* v1, rt1 = eval_expr rt e1 in let* v2, rt2 = eval_expr rt1 e2 in @@ -338,17 +327,18 @@ let rec eval_expr (rt : runtime) = function let* v, rt1 = eval_expr rt e in (match v with | VBool b -> return (VBool (not b), rt1) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) | EUnOp (OpNeg, e) -> let* v, rt1 = eval_expr rt e in (match v with | VInt i -> return (VInt (-i), rt1) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) | EFuncCall (fn_expr, Args args) -> (match fn_expr with | EId id -> (match lookup_func_opt id rt.fenv with - | None -> Error (OtherError ("Function not found: " ^ string_of_ident id)) + | None -> + Error (IError (OtherError ("Function not found: " ^ string_of_ident id))) | Some f -> let rec eval_args rt = function | [] -> return ([], rt) @@ -360,19 +350,19 @@ let rec eval_expr (rt : runtime) = function let* arg_vals, rt2 = eval_args rt args in let* v, rt3 = call_function rt2 f arg_vals in return (v, rt3)) - | _ -> Error (OtherError "Invalid function call")) - | EArrayAccess _ -> Error NotImplemented - | EAwait _ -> Error NotImplemented + | _ -> Error (IError (OtherError "Invalid function call"))) + | EArrayAccess _ -> Error (IError NotImplemented) + | EAwait _ -> Error (IError NotImplemented) -and eval_binop op v1 v2 rt : (value * runtime) res = +and eval_binop op v1 v2 rt = match op, v1, v2 with | OpAdd, VInt a, VInt b -> return (VInt (a + b), rt) | OpSub, VInt a, VInt b -> return (VInt (a - b), rt) | OpMul, VInt a, VInt b -> return (VInt (a * b), rt) | OpDiv, VInt a, VInt b when b <> 0 -> return (VInt (a / b), rt) - | OpDiv, VInt _, VInt 0 -> Error (ImpossibleResult "Div by zero") + | OpDiv, VInt _, VInt 0 -> Error (IError (ImpossibleResult "Div by zero")) | OpMod, VInt a, VInt b when b <> 0 -> return (VInt (a mod b), rt) - | OpMod, VInt _, VInt 0 -> Error (ImpossibleResult "Mod by zero") + | OpMod, VInt _, VInt 0 -> Error (IError (ImpossibleResult "Mod by zero")) | OpEqual, v1, v2 -> return (VBool (v1 = v2), rt) | OpNonEqual, v1, v2 -> return (VBool (v1 <> v2), rt) | OpLess, VInt a, VInt b -> return (VBool (a < b), rt) @@ -381,7 +371,7 @@ and eval_binop op v1 v2 rt : (value * runtime) res = | OpMoreEqual, VInt a, VInt b -> return (VBool (a >= b), rt) | OpAnd, VBool a, VBool b -> return (VBool (a && b), rt) | OpOr, VBool a, VBool b -> return (VBool (a || b), rt) - | _ -> Error NotImplemented + | _ -> Error (IError (ImpossibleResult "Should not completed typecheck")) and call_function (rt : runtime) f args = let caller_env = rt.env in @@ -395,10 +385,10 @@ and call_function (rt : runtime) f args = let* env2 = match env with | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) - | [] -> Error (OtherError "Empty environment in bind_params") + | [] -> Error (IError (OtherError "Empty environment in bind_params")) in bind_params env2 ps vs rt1 - | _ -> Error (OtherError "Argument mismatch") + | _ -> Error (IError (OtherError "Argument mismatch")) in let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in let rt_with_this = { rt_func with curr_object = caller_obj } in @@ -407,7 +397,7 @@ and call_function (rt : runtime) f args = match flow with | Return v -> return (v, restored_rt) | Normal -> return (VNull, restored_rt) - | Break | Continue -> Error (OtherError "Break/continue outside loop") + | Break | Continue -> Error (IError (OtherError "Break/continue outside loop")) and exec_stmt (rt : runtime) = function | SExpr e -> @@ -437,7 +427,7 @@ and exec_stmt (rt : runtime) = function (match else_s with | None -> return (rt1, Normal) | Some s -> exec_stmt rt1 s) - | _ -> Error TypeMismatch) + | _ -> Error (IError TypeMismatch)) | SWhile (cond, body) -> let rec loop rt = let* v, rt1 = eval_expr rt cond in @@ -450,7 +440,7 @@ and exec_stmt (rt : runtime) = function | Break -> return (rt2, Normal) | Return v -> return (rt2, Return v)) | VBool false -> return (rt1, Normal) - | _ -> Error TypeMismatch + | _ -> Error (IError TypeMismatch) in loop rt | SBlock stmts -> @@ -476,7 +466,7 @@ and exec_stmt (rt : runtime) = function let* rt1, r = exec_stmt rt0 s in (match r with | Normal -> return rt1 - | _ -> Error (OtherError "Invalid control flow in for init")) + | _ -> Error (IError (OtherError "Invalid control flow in for init"))) in let rec loop rt = let* cond_val, rt1 = @@ -500,7 +490,7 @@ and exec_stmt (rt : runtime) = function return rt in loop rt3) - | _ -> Error TypeMismatch + | _ -> Error (IError TypeMismatch) in let* rt2, flow = loop rt1 in let* env3 = pop_scope rt2.env in @@ -598,21 +588,18 @@ let interpret_program = function | Some (_, main_func) -> let* v, _ = call_function rt main_func [] in Ok (Some v) - | None -> Error (OtherError "Main method not found")) - | None -> Error (OtherError "No class definition")) + | None -> Error (IError (OtherError "Main method not found"))) + | None -> Error (IError (OtherError "No class definition"))) | Error e -> Error e) ;; let interpret str = + (* TODO: add typecheck *) match apply_parser Parser.parse_prog str with | Ok prog -> interpret_program prog - | Error e -> Error (OtherError e) + | Error _ -> Error (IError (OtherError "Parsing error")) ;; -(* TODO: combine repeated code into functions? - unwrap_return -*) - (* TODO: error messages? *) (* Quicktests for parser diff --git a/CSharpStrange_Kuznetsov/lib/interpret.mli b/CSharpStrange_Kuznetsov/lib/interpret.mli index b0113251..34e79e7e 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.mli +++ b/CSharpStrange_Kuznetsov/lib/interpret.mli @@ -3,20 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Ast - -type interpret_error = - | NotImplemented - | NoVariable of string - | AddressNotFound of int - | VarDeclared of string - | TypeMismatch - | ImpossibleResult of string - | OtherError of string - -type error = IError of interpret_error - -val pp_error : Format.formatter -> error -> unit -val show_error : error -> string +open Common type adr = Adr of int @@ -32,5 +19,5 @@ val pp_value : Format.formatter -> value -> unit val show_value : value -> string (* Main funtions *) -val interpret_program : program -> (value option, interpret_error) result -val interpret : string -> (value option, interpret_error) result +val interpret_program : program -> (value option, error) result +val interpret : string -> (value option, error) result diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index d98b26cc..91b72398 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib.Interpret +open C_sharp_strange_lib.Common let show_wrap str = match interpret str with @@ -10,7 +11,7 @@ let show_wrap str = (match x with | Some x -> Format.printf "Result: '%a'" pp_value x | None -> Format.print_string "Result: void\n") - | Result.Error er -> Format.printf "%a\n%!" pp_error (IError er) + | Result.Error er -> Format.printf "%a\n%!" pp_error er ;; (* TODO: include TC? *) From 0938b6e0537ac2ac0a5fc3ab48a303ebbb8ab997 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sat, 7 Mar 2026 10:34:09 +0300 Subject: [PATCH 61/84] fix: fixed cram test for factorial Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/factorial.cs | 2 +- CSharpStrange_Kuznetsov/tests/ast_fact.t | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/factorial.cs b/CSharpStrange_Kuznetsov/bin/factorial.cs index f85758ec..566bd5a9 100644 --- a/CSharpStrange_Kuznetsov/bin/factorial.cs +++ b/CSharpStrange_Kuznetsov/bin/factorial.cs @@ -14,6 +14,6 @@ public int Factorial(int n) public static void Main() { - + return Factorial(5); } } \ No newline at end of file diff --git a/CSharpStrange_Kuznetsov/tests/ast_fact.t b/CSharpStrange_Kuznetsov/tests/ast_fact.t index 24e62cf1..6176ee41 100644 --- a/CSharpStrange_Kuznetsov/tests/ast_fact.t +++ b/CSharpStrange_Kuznetsov/tests/ast_fact.t @@ -21,6 +21,13 @@ ]) )); (Method ([MPublic; MStatic], TypeVoid, (Id "Main"), (Params []), - (SBlock []))) + (SBlock + [(SReturn + (Some (EFuncCall ((EId (Id "Factorial")), + (Args [(EValue (ValInt 5))]))))) + ]) + )) ] ))) + $ ../bin/REPL.exe -eval -filepath="../bin/factorial.cs" < Date: Sat, 7 Mar 2026 11:11:06 +0300 Subject: [PATCH 62/84] fix: added missing typecheck Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/interpret.ml | 8 ++++++-- CSharpStrange_Kuznetsov/tests/interpret_tests.ml | 15 --------------- CSharpStrange_Kuznetsov/tests/typecheck_tests.ml | 15 +++++++++++++++ 3 files changed, 21 insertions(+), 17 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 7b77c2f4..11f467ca 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -5,6 +5,7 @@ open Ast open Parser open Common +open Typecheck let ( let* ) = Result.bind let return x = Ok x @@ -594,10 +595,13 @@ let interpret_program = function ;; let interpret str = - (* TODO: add typecheck *) match apply_parser Parser.parse_prog str with - | Ok prog -> interpret_program prog | Error _ -> Error (IError (OtherError "Parsing error")) + | Ok (Program prog) -> + (match typecheck_main prog with + | _, Error e -> Error e + | Some _, Ok _ -> interpret_program (Program prog) + | None, Ok _ -> Error (TCError (OtherError "Main method not found"))) ;; (* TODO: error messages? *) diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index 91b72398..bcb07208 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -142,18 +142,3 @@ let%expect_test "Functions 1" = ;; (* TODO: non static not allowed *) - -let%expect_test "Invalid value" = - show_wrap - {| - class Program { - static int Main() { - int a; - int b = a -1 + 4; - return b; - } - } |}; - [%expect - {| - (IError (OtherError "Value is not initialized"))|}] -;; diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index 2f0d7609..29a838a3 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -68,6 +68,21 @@ let%expect_test "Already declared variable" = (TCError (OtherError "This variable is already declared")) |}] ;; +let%expect_test "Invalid value" = + test_ast + {| + class Program { + static int Main() { + int a; + int b = a -1 + 4; + return b; + } + } |}; + [%expect + {| + (TCError (OtherError "Variable not found: a"))|}] +;; + let%expect_test "Checking fields" = test_ast {| From 3eec8c8cb28efa505a29878c4072b540bb7ce0f7 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 9 Mar 2026 17:32:32 +0300 Subject: [PATCH 63/84] fix(tests): some changes in interpreter tests Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/interpret_tests.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index bcb07208..788080e7 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -9,8 +9,8 @@ let show_wrap str = match interpret str with | Result.Ok x -> (match x with - | Some x -> Format.printf "Result: '%a'" pp_value x - | None -> Format.print_string "Result: void\n") + | Some x -> Format.printf "%a" pp_value x + | None -> Format.print_string "void\n") | Result.Error er -> Format.printf "%a\n%!" pp_error er ;; @@ -38,7 +38,7 @@ let%expect_test "Main 1" = } |}; [%expect {| - Result: '-58' |}] + -58 |}] ;; (* TODO: Access to non-static fields from static methods is prohibited @@ -63,7 +63,7 @@ let%expect_test "Main 2" = } |}; [%expect {| - Result: '870' |}] + 870 |}] ;; (* TODO: n without static *) @@ -97,7 +97,7 @@ let%expect_test "Main 3" = } |}; [%expect {| - Result: '141' |}] + 141 |}] ;; let%expect_test "Main 4" = @@ -116,7 +116,7 @@ let%expect_test "Main 4" = } |}; [%expect {| - Result: '18' |}] + 18 |}] ;; let%expect_test "Functions 1" = @@ -138,7 +138,7 @@ let%expect_test "Functions 1" = } |}; [%expect {| - Result: '1' |}] + 1 |}] ;; (* TODO: non static not allowed *) From bc31b04ccf9c708884d9da23d4967c6bca5fbb21 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 9 Mar 2026 17:57:46 +0300 Subject: [PATCH 64/84] fix(tests): updated cram test for factorial Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 4 ++-- CSharpStrange_Kuznetsov/bin/factorial.cs | 4 ++-- CSharpStrange_Kuznetsov/tests/ast_fact.t | 9 ++++++--- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 5347f90c..6d52fe90 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -40,8 +40,8 @@ let () = if opts.eval then ( match interpret_program ast with - | Ok (Some v) -> printf "Result: %s\n" (show_value v) - | Ok None -> printf "Result: void\n" + | Ok (Some v) -> printf "%s\n" (show_value v) + | Ok None -> printf "void\n" | Error _ -> failwith (sprintf "Interpretation error")) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) ;; diff --git a/CSharpStrange_Kuznetsov/bin/factorial.cs b/CSharpStrange_Kuznetsov/bin/factorial.cs index 566bd5a9..0092dd69 100644 --- a/CSharpStrange_Kuznetsov/bin/factorial.cs +++ b/CSharpStrange_Kuznetsov/bin/factorial.cs @@ -1,6 +1,6 @@ public class Program { - public int Factorial(int n) + public static int Factorial(int n) { if (n == 0) { @@ -12,7 +12,7 @@ public int Factorial(int n) } } - public static void Main() + public static int Main() { return Factorial(5); } diff --git a/CSharpStrange_Kuznetsov/tests/ast_fact.t b/CSharpStrange_Kuznetsov/tests/ast_fact.t index 6176ee41..9b448d58 100644 --- a/CSharpStrange_Kuznetsov/tests/ast_fact.t +++ b/CSharpStrange_Kuznetsov/tests/ast_fact.t @@ -1,7 +1,7 @@ $ ../bin/REPL.exe -parseast -filepath="../bin/factorial.cs" (Program (Class ([MPublic], (Id "Program"), - [(Method ([MPublic], (TypeBase TypeInt), (Id "Factorial"), + [(Method ([MPublic; MStatic], (TypeBase TypeInt), (Id "Factorial"), (Params [(Var ((TypeVar (TypeBase TypeInt)), (Id "n")))]), (SBlock [(SIf ((EBinOp (OpEqual, (EId (Id "n")), (EValue (ValInt 0)))), @@ -20,7 +20,8 @@ )) ]) )); - (Method ([MPublic; MStatic], TypeVoid, (Id "Main"), (Params []), + (Method ([MPublic; MStatic], (TypeBase TypeInt), (Id "Main"), + (Params []), (SBlock [(SReturn (Some (EFuncCall ((EId (Id "Factorial")), @@ -29,5 +30,7 @@ )) ] ))) + $ mcs ../bin/factorial.cs && mono ../bin/factorial.exe < Date: Mon, 9 Mar 2026 19:45:53 +0300 Subject: [PATCH 65/84] fix: major improvements for factorial test Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 2 +- CSharpStrange_Kuznetsov/bin/factorial.cs | 3 +- CSharpStrange_Kuznetsov/lib/interpret.ml | 103 +++++++++++++----- CSharpStrange_Kuznetsov/lib/interpret.mli | 6 +- CSharpStrange_Kuznetsov/lib/parser.ml | 3 +- CSharpStrange_Kuznetsov/lib/typecheck.ml | 27 ++++- CSharpStrange_Kuznetsov/tests/ast_fact.t | 16 ++- .../tests/interpret_tests.ml | 48 ++++++-- CSharpStrange_Kuznetsov/tests/makefile | 2 + .../tests/typecheck_tests.ml | 24 ++++ 10 files changed, 184 insertions(+), 50 deletions(-) create mode 100644 CSharpStrange_Kuznetsov/tests/makefile diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 6d52fe90..c529067c 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -40,7 +40,7 @@ let () = if opts.eval then ( match interpret_program ast with - | Ok (Some v) -> printf "%s\n" (show_value v) + | Ok (Some v) -> exit v | Ok None -> printf "void\n" | Error _ -> failwith (sprintf "Interpretation error")) | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) diff --git a/CSharpStrange_Kuznetsov/bin/factorial.cs b/CSharpStrange_Kuznetsov/bin/factorial.cs index 0092dd69..d405f3df 100644 --- a/CSharpStrange_Kuznetsov/bin/factorial.cs +++ b/CSharpStrange_Kuznetsov/bin/factorial.cs @@ -14,6 +14,7 @@ public static int Factorial(int n) public static int Main() { - return Factorial(5); + System.Console.WriteLine(Factorial (5)); + return 0; } } \ No newline at end of file diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 11f467ca..2fa4a6ec 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -6,6 +6,7 @@ open Ast open Parser open Common open Typecheck +(* TODO: monad refactoring *) let ( let* ) = Result.bind let return x = Ok x @@ -57,7 +58,7 @@ type object_state = ; fields : (ident * field_value) list } -(*TODO name*) +(*TODO name?*) type class_def = { fields : (ident * _type * expr option * bool) list ; methods : (ident * func) list @@ -73,6 +74,10 @@ type runtime = ; static_fields : (ident * value) list } +type return_code = int + +(* Printers *) +(* TODO: not need pp? *) let pp_value fmt = function | VInt i -> Format.fprintf fmt "%d" i | VBool b -> Format.fprintf fmt "%b" b @@ -82,6 +87,11 @@ let pp_value fmt = function | VObject (Adr a) -> Format.fprintf fmt "object@%d" a ;; +let value_to_exit_code = function + | VInt i -> i + | _ -> 0 +;; + type exec_result = | Normal | Return of value @@ -349,7 +359,7 @@ let rec eval_expr (rt : runtime) = function return (v :: vs, rt2) in let* arg_vals, rt2 = eval_args rt args in - let* v, rt3 = call_function rt2 f arg_vals in + let* v, rt3 = call_function rt2 f id arg_vals in return (v, rt3)) | _ -> Error (IError (OtherError "Invalid function call"))) | EArrayAccess _ -> Error (IError NotImplemented) @@ -374,31 +384,57 @@ and eval_binop op v1 v2 rt = | OpOr, VBool a, VBool b -> return (VBool (a || b), rt) | _ -> Error (IError (ImpossibleResult "Should not completed typecheck")) -and call_function (rt : runtime) f args = +and call_function (rt : runtime) f id args = let caller_env = rt.env in let caller_obj = rt.curr_object in - let rec bind_params env params args rt = - match params, args with - | [], [] -> return ({ rt with env }, rt) - | p :: ps, v :: vs -> - let loc, rt1 = alloc_r v rt in - let var_info = { loc; initialized = true } in - let* env2 = - match env with - | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) - | [] -> Error (IError (OtherError "Empty environment in bind_params")) - in - bind_params env2 ps vs rt1 - | _ -> Error (IError (OtherError "Argument mismatch")) - in - let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in - let rt_with_this = { rt_func with curr_object = caller_obj } in - let* rt2, flow = exec_stmt rt_with_this f.body in - let restored_rt = { rt2 with env = caller_env; curr_object = caller_obj } in - match flow with - | Return v -> return (v, restored_rt) - | Normal -> return (VNull, restored_rt) - | Break | Continue -> Error (IError (OtherError "Break/continue outside loop")) + match id with + | Id "System.Console.WriteLine" -> + (* Return null *) + let writeline = function + | [] -> + let _ = Format.printf "\n" in + return (VNull, rt) + | [ VInt i ] -> + let _ = Format.printf "%d\n" i in + return (VNull, rt) + | [ VChar c ] -> + let _ = Format.printf "%c\n" c in + return (VNull, rt) + | [ VString s ] -> + let _ = Format.printf "%S\n" s in + return (VNull, rt) + | [ VNull ] -> + let _ = Format.printf "null\n" in + return (VNull, rt) + | [ VObject (Adr a) ] -> + let _ = Format.printf "object@%d\n" a in + return (VNull, rt) + | _ -> Error (IError TypeMismatch) + in + writeline args + | _ -> + let rec bind_params env params args rt = + match params, args with + | [], [] -> return ({ rt with env }, rt) + | p :: ps, v :: vs -> + let loc, rt1 = alloc_r v rt in + let var_info = { loc; initialized = true } in + let* env2 = + match env with + | scope :: rest -> Ok (IdMap.add p var_info scope :: rest) + | [] -> Error (IError (OtherError "Empty environment in bind_params")) + in + bind_params env2 ps vs rt1 + | _ -> Error (IError (OtherError "Argument mismatch")) + in + let* rt_func, _ = bind_params [ IdMap.empty ] f.params args rt in + let rt_with_this = { rt_func with curr_object = caller_obj } in + let* rt2, flow = exec_stmt rt_with_this f.body in + let restored_rt = { rt2 with env = caller_env; curr_object = caller_obj } in + (match flow with + | Return v -> return (v, restored_rt) + | Normal -> return (VNull, restored_rt) + | Break | Continue -> Error (IError (OtherError "Break/continue outside loop"))) and exec_stmt (rt : runtime) = function | SExpr e -> @@ -555,10 +591,21 @@ let rec init_instance_fields rt fields acc = let init_program (Class (_, name, fields)) = let class_def = class_of_ast (Class ([], name, fields)) in let rt = { empty_runtime with class_def = Some class_def } in - let rt_with_methods = + let builtin_functions = + [ Id "System.Console.WriteLine", { params = [ Id "value" ]; body = SBlock [] } + (* TODO: change from call_function and typecheck to some common space *) + ] + in + let rt_with_builtins = List.fold_left (fun rt (id, func) -> { rt with fenv = (id, func) :: rt.fenv }) rt + builtin_functions + in + let rt_with_methods = + List.fold_left + (fun rt (id, func) -> { rt with fenv = (id, func) :: rt.fenv }) + rt_with_builtins class_def.methods in let static_fields = @@ -587,8 +634,8 @@ let interpret_program = function | Some class_def -> (match List.find_opt (fun (id, _) -> id = Id "Main") class_def.methods with | Some (_, main_func) -> - let* v, _ = call_function rt main_func [] in - Ok (Some v) + let* v, _ = call_function rt main_func (Id "Main") [] in + Ok (Some (value_to_exit_code v)) | None -> Error (IError (OtherError "Main method not found"))) | None -> Error (IError (OtherError "No class definition"))) | Error e -> Error e) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.mli b/CSharpStrange_Kuznetsov/lib/interpret.mli index 34e79e7e..fb852a1a 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.mli +++ b/CSharpStrange_Kuznetsov/lib/interpret.mli @@ -18,6 +18,8 @@ type value = val pp_value : Format.formatter -> value -> unit val show_value : value -> string +type return_code = int + (* Main funtions *) -val interpret_program : program -> (value option, error) result -val interpret : string -> (value option, error) result +val interpret_program : program -> (return_code option, error) result +val interpret : string -> (return_code option, error) result diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index 05fe416e..44047bb0 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -51,7 +51,8 @@ let is_space = function ;; let is_token_sym = function - | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '_' -> true + (* TODO: think about . (could be initial namespace) *) + | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '.' | '_' -> true | _ -> false ;; diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 488f741b..8009f72d 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -82,12 +82,32 @@ let get_class_memb id memb = | _ -> None ;; +let builtin_methods = + (* TODO: запрет для других функций с точкой/ начальный namespace ? *) + [ ( Id "System.Console.WriteLine" + , { method_modifiers = [ MStatic ] + ; method_return = TypeVoid + ; method_name = Id "System.Console.WriteLine" + ; method_params = Params [ Var (TypeVar (TypeBase TypeInt), Id "value") ] + ; method_body = SBlock [] (* TODO: making definition here? *) + ; is_static = true + ; is_main = false + } ) + ] +;; + let find_memb_from_obj obj_id id = let find_memb b id f = List.find_map (f id) b in let find_class_memb b id = find_memb b id get_class_memb in read_global_el obj_id >>= function - | TCClass (Class (_, _, b)) -> find_class_memb b id |> return + | TCClass (Class (_, _, b)) -> + (match find_class_memb b id with + | Some memb -> return (Some memb) + | None -> + List.find_opt (fun (builtin_id, _) -> equal_ident builtin_id id) builtin_methods + |> Option.map (fun (_, info) -> TCMethod info) + |> return) ;; let find_memb_type = function @@ -378,11 +398,14 @@ let tc_obj cl = in iter f fields in + let add_builtins = + iter (fun (id, method_info) -> save_decl id (TCMethod method_info)) builtin_methods + in let tc_member_with_fields mem = tc_member mem fields in let tc_mems = iter tc_member_with_fields fields in let save_class = save_global id (TCClass cl) in write_curr_class_name id - *> apply_local (write_mems () *> save_class *> tc_mems) + *> apply_local (write_mems () *> add_builtins *> save_class *> tc_mems) *> return () ;; diff --git a/CSharpStrange_Kuznetsov/tests/ast_fact.t b/CSharpStrange_Kuznetsov/tests/ast_fact.t index 9b448d58..fd2a453f 100644 --- a/CSharpStrange_Kuznetsov/tests/ast_fact.t +++ b/CSharpStrange_Kuznetsov/tests/ast_fact.t @@ -23,14 +23,18 @@ (Method ([MPublic; MStatic], (TypeBase TypeInt), (Id "Main"), (Params []), (SBlock - [(SReturn - (Some (EFuncCall ((EId (Id "Factorial")), - (Args [(EValue (ValInt 5))]))))) - ]) + [(SExpr + (EFuncCall ((EId (Id "System.Console.WriteLine")), + (Args + [(EFuncCall ((EId (Id "Factorial")), + (Args [(EValue (ValInt 5))]))) + ]) + ))); + (SReturn (Some (EValue (ValInt 0))))]) )) ] ))) $ mcs ../bin/factorial.cs && mono ../bin/factorial.exe < (match x with - | Some x -> Format.printf "%a" pp_value x + | Some _ -> () | None -> Format.print_string "void\n") | Result.Error er -> Format.printf "%a\n%!" pp_error er ;; @@ -17,7 +17,7 @@ let show_wrap str = (* TODO: include TC? *) let%expect_test "Main 1" = - show_wrap + test_interpret {| class Program { static int b = 9; @@ -32,6 +32,7 @@ let%expect_test "Main 1" = a = (50 % 2) + b - c; r = s != "kkkk" && (190%22 == 100 * -2/5); t = (a != b * c) || (a >= b) && (a == c +90); + System.Console.WriteLine(a); return a; } @@ -47,7 +48,7 @@ let%expect_test "Main 1" = *) let%expect_test "Main 2" = - show_wrap + test_interpret {| class Program { static int n = 10; @@ -58,6 +59,8 @@ let%expect_test "Main 2" = res = res + i *j; } } + + System.Console.WriteLine(res); return res; } } |}; @@ -69,7 +72,7 @@ let%expect_test "Main 2" = (* TODO: n without static *) let%expect_test "Main 3" = - show_wrap + test_interpret {| class Program { static bool t; @@ -86,6 +89,7 @@ let%expect_test "Main 3" = } else if( a == b) { a = c*67 + 7; + System.Console.WriteLine(a); return a; } } @@ -101,7 +105,7 @@ let%expect_test "Main 3" = ;; let%expect_test "Main 4" = - show_wrap + test_interpret {| class Program { static int x = 189; @@ -111,6 +115,7 @@ let%expect_test "Main 4" = s = s + x % 10; x = x/ 10; } + System.Console.WriteLine(s); return s; } } |}; @@ -120,7 +125,7 @@ let%expect_test "Main 4" = ;; let%expect_test "Functions 1" = - show_wrap + test_interpret {| class Program { public static int is_right_triangle(int a, int b, int c) { @@ -133,12 +138,37 @@ let%expect_test "Functions 1" = } } static int Main() { - return is_right_triangle(3,4,5); + System.Console.WriteLine(is_right_triangle(3,4,5)); + return; } } |}; [%expect {| - 1 |}] + (TCError TypeMismatch) |}] +;; + +let%expect_test "Factorial with writeline" = + test_interpret + {| + class Program { + int Fac(int num) { + if (num == 1) { + return 1; + } + else + { + return num * Fac(num - 1); + } + } + static int Main() { + int result = Fac(5); + System.Console.WriteLine(result); + return result; + } + } |}; + [%expect + {| + 120 |}] ;; (* TODO: non static not allowed *) diff --git a/CSharpStrange_Kuznetsov/tests/makefile b/CSharpStrange_Kuznetsov/tests/makefile new file mode 100644 index 00000000..7e0b6564 --- /dev/null +++ b/CSharpStrange_Kuznetsov/tests/makefile @@ -0,0 +1,2 @@ +install_mono: + sudo apt update && sudo apt install -y mono-complete \ No newline at end of file diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index 29a838a3..5eee4694 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -209,6 +209,30 @@ let%expect_test "Function type mismatch" = (TCError TypeMismatch) |}] ;; +let%expect_test "Factorial with writeline" = + test_ast + {| + class Program { + int Fac(int num) { + if (num == 1) { + return 1; + } + else + { + return num * Fac(num - 1); + } + } + static int Main() { + int result = Fac(5); + System.Console.WriteLine(result); + return result; + } + } |}; + [%expect + {| + Ok! |}] +;; + (* TODO: occurs check test: smth like {| class Program { From 19afe9ec6bb6965f5c73c305c1f6051e6054ef5a Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 9 Mar 2026 19:50:51 +0300 Subject: [PATCH 66/84] fix: deleted makefile Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/makefile | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 CSharpStrange_Kuznetsov/tests/makefile diff --git a/CSharpStrange_Kuznetsov/tests/makefile b/CSharpStrange_Kuznetsov/tests/makefile deleted file mode 100644 index 7e0b6564..00000000 --- a/CSharpStrange_Kuznetsov/tests/makefile +++ /dev/null @@ -1,2 +0,0 @@ -install_mono: - sudo apt update && sudo apt install -y mono-complete \ No newline at end of file From 1dbceb57f18015274566b7b2f0d45097b91ee521 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 9 Mar 2026 20:03:49 +0300 Subject: [PATCH 67/84] feat(tests): added fibonacci test Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/fib.cs | 14 ++++++++++++++ CSharpStrange_Kuznetsov/tests/dune | 6 +++++- .../tests/{ast_fact.t => fact.t} | 0 CSharpStrange_Kuznetsov/tests/fib.t | 4 ++++ 4 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 CSharpStrange_Kuznetsov/bin/fib.cs rename CSharpStrange_Kuznetsov/tests/{ast_fact.t => fact.t} (100%) create mode 100644 CSharpStrange_Kuznetsov/tests/fib.t diff --git a/CSharpStrange_Kuznetsov/bin/fib.cs b/CSharpStrange_Kuznetsov/bin/fib.cs new file mode 100644 index 00000000..5497efa4 --- /dev/null +++ b/CSharpStrange_Kuznetsov/bin/fib.cs @@ -0,0 +1,14 @@ +public class Program { + public static int Fibonacci(int n) + { + if (n <= 1) + { + return n; + } + return Fibonacci(n - 1) + Fibonacci (n - 2); + } + public static int Main() { + System.Console.WriteLine(Fibonacci (6 )); + return 0; + } + } diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index 1e150ae5..71f235a6 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -10,5 +10,9 @@ (pps ppx_expect))) (cram - (applies_to ast_fact) + (applies_to fact) (deps ../bin/REPL.exe ../bin/factorial.cs)) + +(cram + (applies_to fib) + (deps ../bin/REPL.exe ../bin/fib.cs)) diff --git a/CSharpStrange_Kuznetsov/tests/ast_fact.t b/CSharpStrange_Kuznetsov/tests/fact.t similarity index 100% rename from CSharpStrange_Kuznetsov/tests/ast_fact.t rename to CSharpStrange_Kuznetsov/tests/fact.t diff --git a/CSharpStrange_Kuznetsov/tests/fib.t b/CSharpStrange_Kuznetsov/tests/fib.t new file mode 100644 index 00000000..cf10cf07 --- /dev/null +++ b/CSharpStrange_Kuznetsov/tests/fib.t @@ -0,0 +1,4 @@ + $ mcs ../bin/fib.cs && mono ../bin/fib.exe < Date: Mon, 9 Mar 2026 20:11:05 +0300 Subject: [PATCH 68/84] fix: attempt to calm zanuda Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/.zanuda | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CSharpStrange_Kuznetsov/.zanuda b/CSharpStrange_Kuznetsov/.zanuda index 0f09b19b..e7a24505 100644 --- a/CSharpStrange_Kuznetsov/.zanuda +++ b/CSharpStrange_Kuznetsov/.zanuda @@ -1 +1 @@ -forward mutability_check ignore REPL.ml +forward mutability_check ignore bin/REPL.ml From 5c65577ff5eff5cb74a18a80fcdf5a32cbaf2a10 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 13 Mar 2026 15:59:53 +0300 Subject: [PATCH 69/84] refactor(parser): minor changes Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/parser.ml | 13 ++++++++----- CSharpStrange_Kuznetsov/lib/parser.mli | 1 + 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index 44047bb0..f4121a0c 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -160,6 +160,11 @@ let parse_call_args id (arg : expr t) = parse_args_list arg >>= fun args -> return @@ EFuncCall (id, Args args) ;; +let parse_params = + parens (sep_by (skip_spaces *> char ',' <* skip_spaces) parse_var) + >>= fun exp -> return (Params exp) +;; + let parse_call_expr (arg : expr t) = parse_call_id >>= fun id -> parse_call_args id arg (* Operations *) @@ -326,16 +331,12 @@ let parse_method_type = ;; let parse_method_sign = - let parse_args = - parens (sep_by (skip_spaces *> char ',' <* skip_spaces) parse_var) - >>= fun exp -> return (Params exp) - in lift4 (fun m_modif m_type m_id m_params -> m_modif, m_type, m_id, m_params) (skip_spaces *> parse_modifiers) (skip_spaces *> parse_method_type) (skip_spaces *> parse_id) - (skip_spaces *> parse_args) + (skip_spaces *> parse_params) ;; let parse_method_member = @@ -381,3 +382,5 @@ let parse_option p str = | Ok x -> Some x | Error _ -> None ;; + +(* TODO: lambda parsing??? *) diff --git a/CSharpStrange_Kuznetsov/lib/parser.mli b/CSharpStrange_Kuznetsov/lib/parser.mli index b2530616..46ad6449 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.mli +++ b/CSharpStrange_Kuznetsov/lib/parser.mli @@ -17,6 +17,7 @@ val parse_val_string : val_type t val parse_modifiers : modifier list t val parse_ops : expr t val parse_decl : stmt t +val parse_stmt_ops : stmt t val parse_return : stmt t val parse_break : stmt t val parse_continue : stmt t From 60ce64ef38dd52fa25f29a382d367a39b03fe203 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 13 Mar 2026 17:16:14 +0300 Subject: [PATCH 70/84] feat(tests): added more pp tests Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/pp_tests.ml | 321 ++++++++++++++++++++-- 1 file changed, 291 insertions(+), 30 deletions(-) diff --git a/CSharpStrange_Kuznetsov/tests/pp_tests.ml b/CSharpStrange_Kuznetsov/tests/pp_tests.ml index 3a4ccba6..0d45df2d 100644 --- a/CSharpStrange_Kuznetsov/tests/pp_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/pp_tests.ml @@ -6,8 +6,36 @@ open C_sharp_strange_lib.Prettyprinter open C_sharp_strange_lib.Parser open Format -let fact_str = - {| +(* Debug (TODO remove later) +let test_pp name source = + let prog = parse_option parse_prog source in + let pretty = + match prog with + | Some x -> asprintf "%a" pp_prog x + | None -> "" + in + let prog_after_pp = parse_option parse_prog pretty in + if prog = prog_after_pp + then Printf.printf "✓ %s: roundtrip successful\n" name + else Printf.printf "✗ %s: roundtrip failed\n" name; + prog = prog_after_pp +;; +*) + +let test_pp _ source = + let prog = parse_option parse_prog source in + let pretty = + match prog with + | Some x -> asprintf "%a" pp_prog x + | None -> "" + in + let prog_after_pp = parse_option parse_prog pretty in + prog = prog_after_pp +;; + +let samples = + [ ( "Factorial" + , {| public class Program { public int Factorial(int n) @@ -24,25 +52,12 @@ public class Program public static void Main() { - } } - |} -;; - -let fact_prog = parse_option parse_prog fact_str - -let pretty_fact_str = function - | Some x -> asprintf "%a" pp_prog x - | None -> "" -;; - -let parse_after_pp prog = parse_option parse_prog (pretty_fact_str prog) -let%test "Factorial pp" = parse_after_pp fact_prog = fact_prog - -let cycles_str = - {| + ) + ; ( "Cycles 1" + , {| public class Program { public int Cycles(int n, bool e, string x) @@ -85,16 +100,9 @@ public class Program } } |} -;; - -let cycles_prog = parse_option parse_prog cycles_str -let%test "Cycles pp" = parse_after_pp cycles_prog = cycles_prog - -let binops_prog = - parse_option - parse_prog - {| - + ) + ; ( "Binops 1" + , {| public class Program { public int Binops(int n, bool e, string x) @@ -107,13 +115,266 @@ public class Program const int a = 1; } - public static void Main() { Binops(5, true, ""); } } |} + ) + ; ( "StaticClass" + , {| +public static class Program { + static int result = 0; + + public static void Main(string[] args) { + int a = 5; + int b = 3; + result = a + b * 2; + + if (result > 10) { + result = result - 10; + } + + return; + } +} +|} + ) + ; ( "EmptyClass" + , {| +public static class Program { + public static void Main() { + { + { + + } + } + } +} +|} + ) + ; ( "MultipleFields" + , {| +public class Test { + int a, b, c; + static string x, y; + const int MAX = 100; +} +|} + ) + ; ( "Simple arithmetic" + , {| +public static class Program { + static int result = 0; + + public static void Main(string[] args) { + int a = 5; + int b = 3; + result = a + b * 2; + + if (result > 10) { + result = result - 10; + } + + return; + } +} +|} + ) + ; ( "Cycles 2" + , {| +public static class Program { + static int sum = 0; + + public static void Main(string[] args) { + int i = 0; + + while (i < 5) { + sum = sum + i; + i = i + 1; + } + + for (int j = 0; j < 3; j = j + 1) { + sum = sum + j; + } + + return; + } +} +|} + ) + ; ( "Boolean" + , {| +public static class Program { + static bool flag = true; + static int value = 42; + + public static void Main(string[] args) { + bool condition = flag && (value > 40); + + if (condition) { + value = 100; + } else { + value = 0; + } + + if (value == 100) { + flag = false; + } + + return; + } +} +|} + ) + ; ( "Strings & chars" + , {| +public static class Program { + static string message = "Hello"; + static char symbol = 'A'; + + public static void Main(string[] args) { + string name = "World"; + string result = message + " " + name; + + char nextSymbol = symbol + 1; + + if (result != "Hello World") { + result = "Error"; + } + + return; + } +} +|} + ) + ; ( "Cycles 3" + , {| +public static class Program { + static int counter = 0; + + public static void Main(string[] args) { + for (int i = 0; i < 10; i = i + 1) { + if (i == 3) { + continue; + } + + counter = counter + 1; + + if (counter > 5) { + break; + } + + { + int temp = counter * 2; + counter = temp; + } + } + + return; + } +} +|} + ) + ; ( "Complex exprs" + , {| +public static class Program { + static int x = 10; + static int y = 20; + static bool ok = true; + + public static void Main(string[] args) { + int result = (x + y) * (x - y) / 2; + + bool check = (x > y) && ok || (x <= y); + + if (!check && result != 0) { + result = -result; + } + + return; + } +} +|} + ) + ; ( "Multiple definitions" + , {| +public static class Program { + static int a = 1; + static int b = 2; + static string s1 = "first"; + static string s2 = "second"; + static bool b1 = true; + static bool b2 = false; + static char c1 = 'X'; + static char c2 = 'Y'; + + public static void Main(string[] args) { + int x = a + b; + string text = s1 + s2; + bool flag = b1 && b2; + char letter = c1; + + return; + } +} +|} + ) + ; ( "Binops 2" + , {| +public static class Program { + static int value = 100; + + public static void Main(string[] args) { + int a = 5; + int b = 3; + + int sum = a + b; + int sub = a - b; + int mul = a * b; + int div = a / b; + int mod = a % b; + + bool eq = a == b; + bool neq = a != b; + bool lt = a < b; + bool gt = a > b; + bool lte = a <= b; + bool gte = a >= b; + + bool and = true && false; + bool or = true || false; + bool not = !true; + + int neg = -a; + + return; + } +} +|} + ) + ] +;; + +let%test "All pp roundtrip tests" = + List.for_all (fun (name, source) -> test_pp name source) samples ;; -let%test "Binops pp" = parse_after_pp binops_prog = binops_prog +(* TODO: check string[] args later!! *) + +(* TODO: simple arrays: + +public static class Program { + static int[] numbers = null; + + public static void Main(string[] args) { + int index = 0; + int value = numbers[index]; + + numbers[index + 1] = value * 2; + + return; + } +} +*) From 0d15c0e17ea9e633d1a0e87d9aa635b2ec6195d4 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 13 Mar 2026 17:16:44 +0300 Subject: [PATCH 71/84] fix: typecheck tests renaming Signed-off-by: f1i3g3 --- .../tests/typecheck_tests.ml | 63 +++++++++++++++---- 1 file changed, 50 insertions(+), 13 deletions(-) diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index 5eee4694..d598254c 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -16,10 +16,10 @@ let show_wrap = function ;; let print_tc p str = show_wrap (parse_option p str) -let test_ast = print_tc parse_prog +let test_typecheck = print_tc parse_prog let%expect_test "Factorial" = - test_ast + test_typecheck {| class Program { int Fac(int num) { @@ -41,7 +41,7 @@ let%expect_test "Factorial" = ;; let%expect_test "Wrong factorial" = - test_ast + test_typecheck {| class Program { int Fac(int num) { @@ -56,7 +56,7 @@ let%expect_test "Wrong factorial" = ;; let%expect_test "Already declared variable" = - test_ast + test_typecheck {| class Program { int a = 5; @@ -69,7 +69,7 @@ let%expect_test "Already declared variable" = ;; let%expect_test "Invalid value" = - test_ast + test_typecheck {| class Program { static int Main() { @@ -84,7 +84,7 @@ let%expect_test "Invalid value" = ;; let%expect_test "Checking fields" = - test_ast + test_typecheck {| class Program { int b = 9; @@ -107,7 +107,7 @@ let%expect_test "Checking fields" = (* TODO: parser check! *) let%expect_test "String + int" = - test_ast + test_typecheck {| class Program { string a = "5"; @@ -121,7 +121,7 @@ let%expect_test "String + int" = (* TODO: string! *) let%expect_test "While" = - test_ast + test_typecheck {| class Program { static int Main() { @@ -147,7 +147,7 @@ let%expect_test "While" = ;; let%expect_test "For" = - test_ast + test_typecheck {| class Program { int n = 10; @@ -171,7 +171,7 @@ let%expect_test "For" = ;; let%expect_test "Wrong main" = - test_ast + test_typecheck {| class Program { public async void Main() {} @@ -184,7 +184,7 @@ let%expect_test "Wrong main" = ;; let%expect_test "Already declared function" = - test_ast + test_typecheck {| class Program { void Test() {} @@ -197,7 +197,7 @@ let%expect_test "Already declared function" = ;; let%expect_test "Function type mismatch" = - test_ast + test_typecheck {| class Program { public void a(int n, int m){ @@ -210,7 +210,7 @@ let%expect_test "Function type mismatch" = ;; let%expect_test "Factorial with writeline" = - test_ast + test_typecheck {| class Program { int Fac(int num) { @@ -233,6 +233,43 @@ let%expect_test "Factorial with writeline" = Ok! |}] ;; +(* + let%expect_test "Typecheck local variable shadows built-in" = + test_typecheck + {| + public static class Program { + public static int Main() { + int System = 42; + System.Console.WriteLine(10); // Error: System is int + return System; + } + } |}; + [%expect {| (TCError ) |}] +;; + +(* TODO: think about forbidden names *) + +(* 2. Параметр функции перекрывает встроенную функцию *) +let%expect_test "TC: parameter shadows built-in" = + test_typecheck + {| + public class Program { + public static int Print(int Console) { + Console.WriteLine("Hello"); // Error: Console is int + return Console * 2; + } + public static int Main() { + return Print(21); + } + } |}; + [%expect + {| + (TCError + (OtherError "Cannot call a variable as a method")) |}] +;; +(* TODO: parsing error *) +*) + (* TODO: occurs check test: smth like {| class Program { From 4e4ee209f536c62ad1d9b1f9ebe24ca56c27f152 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Fri, 13 Mar 2026 20:21:10 +0300 Subject: [PATCH 72/84] fix(parser): some fixes Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam | 1 + CSharpStrange_Kuznetsov/dune-project | 1 + CSharpStrange_Kuznetsov/lib/prettyprinter.ml | 9 +++++---- CSharpStrange_Kuznetsov/lib/prettyprinter.mli | 5 +++++ CSharpStrange_Kuznetsov/tests/pp_tests.ml | 5 +++-- 5 files changed, 15 insertions(+), 6 deletions(-) diff --git a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam index 7dd3f1e4..832b2b50 100644 --- a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam +++ b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam @@ -20,6 +20,7 @@ depends: [ "odoc" {with-doc} "ocamlformat" {build} "base" + "qcheck" ] build: [ ["dune" "subst"] {dev} diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index 4f328d98..fc8a68aa 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -31,5 +31,6 @@ (odoc :with-doc) (ocamlformat :build) base + qcheck ; After adding dependencies to 'dune' files add the same dependecies here too )) diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml index f2dd2844..69fa9f58 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml @@ -75,10 +75,11 @@ let pp_val_type fmt = function | ValString s -> fprintf fmt {|%S|} s ;; +(* TODO: priorities *) let rec pp_expr fmt = function | EValue v -> pp_val_type fmt v - | EBinOp (op, e1, e2) -> fprintf fmt "(%a %a %a)" pp_expr e1 pp_bin_op op pp_expr e2 - | EUnOp (op, e) -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e + | EBinOp (op, e1, e2) -> fprintf fmt "%a %a %a" pp_expr e1 pp_bin_op op pp_expr e2 + | EUnOp (op, e) -> fprintf fmt "%a%a" pp_un_op op pp_expr e | EId id -> pp_ident fmt id | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 | EFuncCall (e, Args args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args @@ -89,7 +90,7 @@ let rec pp_stmt fmt = function | SFor (init, cond, incr, body) -> fprintf fmt - "@[for (%a; %a; %a) {@ %a@]@ }" + "@[for (%a; %a; %a) { %a@] }" (pp_option pp_stmt) init (pp_option pp_expr) @@ -119,7 +120,7 @@ let rec pp_stmt fmt = function and pp_sblock fmt = function | [] -> fprintf fmt "" - | stmts -> fprintf fmt "@[%a@]" (pp_list pp_stmt "@ ") stmts + | stmts -> fprintf fmt "@[%a@]" (pp_list pp_stmt " ") stmts ;; let pp_field fmt = function diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli index d55fd9f2..bbff649f 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli @@ -5,3 +5,8 @@ open Ast val pp_prog : Format.formatter -> program -> unit +val pp_expr : Format.formatter -> expr -> unit +val pp_stmt : Format.formatter -> stmt -> unit +val pp_field : Format.formatter -> field -> unit +val pp_ident : Format.formatter -> ident -> unit +val pp_type : Format.formatter -> _type -> unit diff --git a/CSharpStrange_Kuznetsov/tests/pp_tests.ml b/CSharpStrange_Kuznetsov/tests/pp_tests.ml index 0d45df2d..12fe81bf 100644 --- a/CSharpStrange_Kuznetsov/tests/pp_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/pp_tests.ml @@ -2,8 +2,9 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open C_sharp_strange_lib.Prettyprinter -open C_sharp_strange_lib.Parser +open C_sharp_strange_lib +open Prettyprinter +open Parser open Format (* Debug (TODO remove later) From e7ada6a4ca736ae8d24ea7e61e5abebdb3c1e73c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sun, 15 Mar 2026 18:59:51 +0300 Subject: [PATCH 73/84] feat(parser): added qcheck tests for parser & pp Signed-off-by: f1i3g3 --- .../CSharpStrange_Kuznetsov.opam | 2 +- CSharpStrange_Kuznetsov/dune-project | 2 +- CSharpStrange_Kuznetsov/lib/parser.mli | 184 ++- CSharpStrange_Kuznetsov/lib/prettyprinter.ml | 95 +- CSharpStrange_Kuznetsov/lib/prettyprinter.mli | 62 +- CSharpStrange_Kuznetsov/tests/dune | 15 +- CSharpStrange_Kuznetsov/tests/qt_test.t | 10 + CSharpStrange_Kuznetsov/tests/qt_tests.ml | 1078 +++++++++++++++++ 8 files changed, 1392 insertions(+), 56 deletions(-) create mode 100644 CSharpStrange_Kuznetsov/tests/qt_test.t create mode 100644 CSharpStrange_Kuznetsov/tests/qt_tests.ml diff --git a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam index 832b2b50..40edc1d1 100644 --- a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam +++ b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "0.2" +version: "0.3" synopsis: "An interpreter for strange subset of C# language" description: "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)" diff --git a/CSharpStrange_Kuznetsov/dune-project b/CSharpStrange_Kuznetsov/dune-project index fc8a68aa..14d4b70e 100644 --- a/CSharpStrange_Kuznetsov/dune-project +++ b/CSharpStrange_Kuznetsov/dune-project @@ -20,7 +20,7 @@ (description "An interpreter for subset of C# language (some stuff like async/await and LINQ will be added later)") (documentation "https://kakadu.github.io/fp25/docs/CSharpStrange_Kuznetsov") - (version 0.2) + (version 0.3) (depends dune angstrom diff --git a/CSharpStrange_Kuznetsov/lib/parser.mli b/CSharpStrange_Kuznetsov/lib/parser.mli index 46ad6449..d3a862af 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.mli +++ b/CSharpStrange_Kuznetsov/lib/parser.mli @@ -2,29 +2,167 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +(** Parser for C#-like language *) + open Ast -open Angstrom -open Base +(** {1 Basic parsers} *) + +(** List of reserved keywords *) val reserved : string list -val parens : 'a t -> 'a t -val braces : 'a t -> 'a t -val brackets : 'a t -> 'a t -val parse_int : val_type t -val parse_char : val_type t -val parse_bool : val_type t -val parse_val_string : val_type t -val parse_modifiers : modifier list t -val parse_ops : expr t -val parse_decl : stmt t -val parse_stmt_ops : stmt t -val parse_return : stmt t -val parse_break : stmt t -val parse_continue : stmt t -val parse_block : stmt t -val parse_method_member : field t -val parse_field_member : field t -val parse_class : c_sharp_class t -val parse_prog : program t -val apply_parser : 'a t -> string -> ('a, string) Result.t -val parse_option : 'a t -> string -> 'a option + +(** Check if a string is a reserved keyword *) +val in_reserved : string -> bool + +(** Check if character is a whitespace *) +val is_space : char -> bool + +(** Check if character can be part of a token (letter, digit, underscore) *) +val is_token_sym : char -> bool + +(** Parser that skips whitespace characters *) +val skip_spaces : unit Angstrom.t + +(** [parens p] parses [p] enclosed in parentheses *) +val parens : 'a Angstrom.t -> 'a Angstrom.t + +(** [braces p] parses [p] enclosed in curly braces *) +val braces : 'a Angstrom.t -> 'a Angstrom.t + +(** [brackets p] parses [p] enclosed in square brackets *) +val brackets : 'a Angstrom.t -> 'a Angstrom.t + +(** Skips zero or more semicolons *) +val skip_semicolons : unit Angstrom.t + +(** Skips one or more semicolons *) +val skip_semicolons1 : unit Angstrom.t + +(** {1 Value parsers} *) + +(** Parses integer literals *) +val parse_int : val_type Angstrom.t + +(** Parses character literals (e.g., 'a') *) +val parse_char : val_type Angstrom.t + +(** Parses boolean literals (true/false) *) +val parse_bool : val_type Angstrom.t + +(** Parses string literals (e.g., "hello") *) +val parse_val_string : val_type Angstrom.t + +(** Parses null literal *) +val parse_null : val_type Angstrom.t + +(** Parses any value literal as expression *) +val parse_value : expr Angstrom.t + +(** {1 Identifier parsers} *) + +(** Parses identifiers (must not be reserved words) *) +val parse_id : ident Angstrom.t + +(** {1 Type parsers} *) + +(** Parses type keywords (int, char, bool, string) *) +val parse_type_word : base_type Angstrom.t + +(** Parses base types (TypeInt, TypeChar, TypeBool, TypeString) *) +val parse_base_type : _type Angstrom.t + +(** Parses variable types (TypeVar of base_type) *) +val parse_var_type : var_type Angstrom.t + +(** Parses method return types (including void) *) +val parse_method_type : _type Angstrom.t + +(** {1 Modifier parsers} *) + +(** Parses zero or more modifiers (public, static, async) *) +val parse_modifiers : modifier list Angstrom.t + +(** {1 Expression parsers} *) + +(** Main expression parser with operator precedence *) +val parse_ops : expr Angstrom.t + +(** Parses assignment expressions *) +val parse_assign : expr Angstrom.t + +(** Parses identifier as expression *) +val parse_id_expr : expr Angstrom.t + +(** [parse_call_expr arg] parses function calls with given argument parser *) +val parse_call_expr : expr Angstrom.t -> expr Angstrom.t + +(** {1 Statement parsers} *) + +(** Parses variable declarations *) +val parse_decl : stmt Angstrom.t + +(** Parses expression statements *) +val parse_stmt_ops : stmt Angstrom.t + +(** [parse_if_else body] parses if-else statements with given body parser *) +val parse_if_else : stmt Angstrom.t -> stmt Angstrom.t + +(** [parse_for body] parses for loops with given body parser *) +val parse_for : stmt Angstrom.t -> stmt Angstrom.t + +(** [parse_while body] parses while loops with given body parser *) +val parse_while : stmt Angstrom.t -> stmt Angstrom.t + +(** Parses return statements *) +val parse_return : stmt Angstrom.t + +(** Parses break statements *) +val parse_break : stmt Angstrom.t + +(** Parses continue statements *) +val parse_continue : stmt Angstrom.t + +(** Parses block statements (enclosed in {}) *) +val parse_block : stmt Angstrom.t + +(** {1 Class and program parsers} *) + +(** Parses variable declarations (type + identifier) *) +val parse_var : var_decl Angstrom.t + +(** Parses field signatures (modifiers, type, identifier, optional initializer) *) +val parse_field_sign : (modifier list * var_type * ident * expr option) Angstrom.t + +(** Parses method signatures (modifiers, return type, identifier, parameters) *) +val parse_method_sign : (modifier list * _type * ident * params) Angstrom.t + +(** Parses complete method definitions *) +val parse_method_member : field Angstrom.t + +(** Parses complete field definitions *) +val parse_field_member : field Angstrom.t + +(** Parses class members (fields and methods) enclosed in braces *) +val parse_class_members : field list Angstrom.t + +(** Parses complete class definitions *) +val parse_class : c_sharp_class Angstrom.t + +(** Parses complete programs *) +val parse_prog : program Angstrom.t + +(** {1 Utility functions} *) + +(** [apply_parser parser str] applies parser to string and returns result *) +val apply_parser : 'a Angstrom.t -> string -> ('a, string) result + +(** [parse_option parser str] tries to parse and returns option *) +val parse_option : 'a Angstrom.t -> string -> 'a option + +(** {1 Chain combinators} *) + +(** Left-associative chaining combinator *) +val chainl1 : 'a Angstrom.t -> ('a -> 'a -> 'a) Angstrom.t -> 'a Angstrom.t + +(** Right-associative chaining combinator *) +val chainr1 : 'a Angstrom.t -> ('a -> 'a -> 'a) Angstrom.t -> 'a Angstrom.t diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml index 69fa9f58..7125ffbd 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml @@ -17,7 +17,7 @@ let pp_list : 'a. (formatter -> 'a -> unit) -> string -> formatter -> 'a list -> let pp_option : 'a. (formatter -> 'a -> unit) -> formatter -> 'a option -> unit = fun pp fmt -> function - | None -> fprintf fmt "" + | None -> () | Some x -> pp fmt x ;; @@ -72,14 +72,17 @@ let pp_val_type fmt = function | ValChar c -> fprintf fmt "'%c'" c | ValNull -> fprintf fmt "null" | ValBool b -> fprintf fmt "%b" b - | ValString s -> fprintf fmt {|%S|} s + | ValString s -> fprintf fmt {|"%s"|} s ;; -(* TODO: priorities *) let rec pp_expr fmt = function | EValue v -> pp_val_type fmt v - | EBinOp (op, e1, e2) -> fprintf fmt "%a %a %a" pp_expr e1 pp_bin_op op pp_expr e2 - | EUnOp (op, e) -> fprintf fmt "%a%a" pp_un_op op pp_expr e + | EBinOp (OpAssign, EId id, e) -> fprintf fmt "%a = %a" pp_ident id pp_expr e + | EBinOp (op, e1, e2) -> fprintf fmt "(%a %a %a)" pp_expr e1 pp_bin_op op pp_expr e2 + | EUnOp (op, e) -> + (match e with + | EValue _ | EId _ -> fprintf fmt "%a%a" pp_un_op op pp_expr e + | _ -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e) | EId id -> pp_ident fmt id | EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2 | EFuncCall (e, Args args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args @@ -88,35 +91,75 @@ let rec pp_expr fmt = function let rec pp_stmt fmt = function | SFor (init, cond, incr, body) -> + let pp_init fmt = function + | None -> fprintf fmt "" + | Some stmt -> + (match stmt with + | SDecl (vd, e) -> + fprintf + fmt + "%a%a" + pp_var_decl + vd + (fun fmt -> function + | None -> () + | Some expr -> fprintf fmt " = %a" pp_expr expr) + e + | SExpr e -> pp_expr fmt e + | _ -> pp_stmt fmt stmt) + in fprintf fmt - "@[for (%a; %a; %a) { %a@] }" - (pp_option pp_stmt) + "@[for (%a%a%a) {@ %a@]@ }" + pp_init init - (pp_option pp_expr) + (fun fmt -> function + | None -> fprintf fmt ";" + | Some e -> fprintf fmt "; %a" pp_expr e) cond - (pp_option pp_expr) + (fun fmt -> function + | None -> fprintf fmt ";" + | Some e -> fprintf fmt "; %a" pp_expr e) incr pp_stmt body | SIf (cond, then_branch, else_branch) -> - fprintf - fmt - "@[if (%a) {@ %a@]@ }%a" - pp_expr - cond - pp_stmt - then_branch - (pp_option (fun fmt -> fprintf fmt "@ @[else {@ %a@]@ }" pp_stmt)) - else_branch + (match else_branch with + | None -> fprintf fmt "@[if (%a) {@ %a@]@ }" pp_expr cond pp_stmt then_branch + | Some else_stmt -> + fprintf + fmt + "@[if (%a) {@ %a@]@ }@ @[else {@ %a@]@ }@ " + pp_expr + cond + pp_stmt + then_branch + pp_stmt + else_stmt) | SWhile (cond, body) -> fprintf fmt "@[while (%a) {@ %a@]@ }" pp_expr cond pp_stmt body - | SReturn e -> fprintf fmt "return %a;" (pp_option pp_expr) e + | SReturn e -> + fprintf + fmt + "return%a;" + (fun fmt -> function + | None -> () + | Some expr -> fprintf fmt " %a" pp_expr expr) + e | SBlock stmts -> pp_sblock fmt stmts | SBreak -> fprintf fmt "break;" | SContinue -> fprintf fmt "continue;" | SExpr e -> fprintf fmt "%a;" pp_expr e - | SDecl (vd, e) -> fprintf fmt "%a = %a;" pp_var_decl vd (pp_option pp_expr) e + | SDecl (vd, e) -> + fprintf + fmt + "%a%a;" + pp_var_decl + vd + (fun fmt -> function + | None -> () + | Some expr -> fprintf fmt " = %a" pp_expr expr) + e and pp_sblock fmt = function | [] -> fprintf fmt "" @@ -127,14 +170,22 @@ let pp_field fmt = function | VarField (mods, t, id, e) -> fprintf fmt - "@[%a %a %a = %a;@]" + "%a %a %a%a;" (pp_list pp_modifier " ") mods pp_var_type t pp_ident id - (pp_option pp_expr) + (fun fmt -> function + | None -> () + | Some expr -> + let init_expr = + match expr with + | EBinOp (OpAssign, _, e) -> e + | _ -> expr + in + fprintf fmt " = %a" pp_expr init_expr) e | Method (mods, t, id, Params params, body) -> fprintf diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli index bbff649f..e67024f7 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.mli +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.mli @@ -2,11 +2,57 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Ast - -val pp_prog : Format.formatter -> program -> unit -val pp_expr : Format.formatter -> expr -> unit -val pp_stmt : Format.formatter -> stmt -> unit -val pp_field : Format.formatter -> field -> unit -val pp_ident : Format.formatter -> ident -> unit -val pp_type : Format.formatter -> _type -> unit +open Format + +(** [pp_list pp sep fmt lst] prints a list [lst], using [pp] to print + elements and [sep] as separator between them *) +val pp_list : (formatter -> 'a -> unit) -> string -> formatter -> 'a list -> unit + +(** [pp_option pp fmt opt] prints an optional value [opt], using [pp] + to print the value if it exists *) +val pp_option : (formatter -> 'a -> unit) -> formatter -> 'a option -> unit + +(** [pp_ident fmt id] prints an identifier *) +val pp_ident : formatter -> Ast.ident -> unit + +(** [pp_base_type fmt bt] prints a base type (int, char, bool, string) *) +val pp_base_type : formatter -> Ast.base_type -> unit + +(** [pp_type fmt t] prints a type (base type or void) *) +val pp_type : formatter -> Ast._type -> unit + +(** [pp_var_type fmt vt] prints a variable type *) +val pp_var_type : formatter -> Ast.var_type -> unit + +(** [pp_modifier fmt m] prints a modifier (public, static, async) *) +val pp_modifier : formatter -> Ast.modifier -> unit + +(** [pp_var_decl fmt vd] prints a variable declaration *) +val pp_var_decl : formatter -> Ast.var_decl -> unit + +(** [pp_bin_op fmt op] prints a binary operator *) +val pp_bin_op : formatter -> Ast.bin_op -> unit + +(** [pp_un_op fmt op] prints a unary operator *) +val pp_un_op : formatter -> Ast.un_op -> unit + +(** [pp_val_type fmt v] prints a literal value (number, character, null, bool, string) *) +val pp_val_type : formatter -> Ast.val_type -> unit + +(** [pp_expr fmt e] prints an expression *) +val pp_expr : formatter -> Ast.expr -> unit + +(** [pp_stmt fmt s] prints a statement *) +val pp_stmt : formatter -> Ast.stmt -> unit + +(** [pp_sblock fmt stmts] prints a block of statements *) +val pp_sblock : formatter -> Ast.stmt list -> unit + +(** [pp_field fmt f] prints a class field (variable or method) *) +val pp_field : formatter -> Ast.field -> unit + +(** [pp_c_sharp_class fmt cls] prints a class definition *) +val pp_c_sharp_class : formatter -> Ast.c_sharp_class -> unit + +(** [pp_prog fmt prog] prints a program (class) *) +val pp_prog : formatter -> Ast.program -> unit diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index 71f235a6..c03e274a 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -2,13 +2,22 @@ (name tests) (public_name CSharpStrange_Kuznetsov.Lib.Tests) (modules Parser_tests Pp_tests Typecheck_tests Interpret_tests) - (libraries angstrom c_sharp_strange_lib qcheck) + (libraries angstrom c_sharp_strange_lib) (inline_tests) (instrumentation (backend bisect_ppx)) (preprocess (pps ppx_expect))) +(executable + (name qt_tests) + (modules Qt_tests) + (libraries c_sharp_strange_lib qcheck tests) + (preprocess + (pps ppx_expect)) + (instrumentation + (backend bisect_ppx))) + (cram (applies_to fact) (deps ../bin/REPL.exe ../bin/factorial.cs)) @@ -16,3 +25,7 @@ (cram (applies_to fib) (deps ../bin/REPL.exe ../bin/fib.cs)) + +(cram + (applies_to qt_test) + (deps qt_tests.exe)) diff --git a/CSharpStrange_Kuznetsov/tests/qt_test.t b/CSharpStrange_Kuznetsov/tests/qt_test.t new file mode 100644 index 00000000..2905aa4a --- /dev/null +++ b/CSharpStrange_Kuznetsov/tests/qt_test.t @@ -0,0 +1,10 @@ + $ ./qt_tests.exe --seed 42 + random seed: 42 + generated error fail pass / total time test name + ✓] 200 0 0 200 / 200 0.0s Parser does not crash on valid expressions + ✓] 200 0 0 200 / 200 0.0s Expression roundtrip: show -> parse -> show + ✓] 200 0 0 200 / 200 0.0s Operator precedence is preserved + roundtrip: show -> parse -> show✓] 200 0 0 200 / 200 0.0s Program roundtrip: show -> parse -> show + ✓] 200 0 0 200 / 200 0.0s Parser returns error on invalid input + ================================================================================ + success (ran 5 tests) diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml new file mode 100644 index 00000000..e27ddfb8 --- /dev/null +++ b/CSharpStrange_Kuznetsov/tests/qt_tests.ml @@ -0,0 +1,1078 @@ +(* qt_tests.ml *) +(* TODO: refactor + add to README *) + +open C_sharp_strange_lib +open QCheck +open Gen +open Ast + +(* =========================================================================== *) +(* Basic generators *) +(* =========================================================================== *) + +(* Basic characters and strings *) +let gen_alpha = Gen.(oneof [ char_range 'a' 'z'; char_range 'A' 'Z' ]) +let gen_digit = Gen.char_range '0' '9' +let gen_ident_char = Gen.(oneof [ gen_alpha; gen_digit; return '_' ]) + +(* Generator for safe string characters *) +let gen_safe_char = + let safe_chars = + [ 'a' + ; 'b' + ; 'c' + ; 'd' + ; 'e' + ; 'f' + ; 'g' + ; 'h' + ; 'i' + ; 'j' + ; 'k' + ; 'l' + ; 'm' + ; 'n' + ; 'o' + ; 'p' + ; 'q' + ; 'r' + ; 's' + ; 't' + ; 'u' + ; 'v' + ; 'w' + ; 'x' + ; 'y' + ; 'z' + ; 'A' + ; 'B' + ; 'C' + ; 'D' + ; 'E' + ; 'F' + ; 'G' + ; 'H' + ; 'I' + ; 'J' + ; 'K' + ; 'L' + ; 'M' + ; 'N' + ; 'O' + ; 'P' + ; 'Q' + ; 'R' + ; 'S' + ; 'T' + ; 'U' + ; 'V' + ; 'W' + ; 'X' + ; 'Y' + ; 'Z' + ; '0' + ; '1' + ; '2' + ; '3' + ; '4' + ; '5' + ; '6' + ; '7' + ; '8' + ; '9' + ; ' ' + ; '_' + ; '-' + ; '+' + ; '*' + ; '/' + ; '=' + ; '(' + ; ')' + ; '.' + ; ',' + ; ';' + ; ':' + ; '!' + ; '?' + ] + in + Gen.oneof (List.map return safe_chars) +;; + +(* Char generator *) +let gen_printable_char = + let printable_chars = + [ 'a' + ; 'b' + ; 'c' + ; 'd' + ; 'e' + ; 'f' + ; 'g' + ; 'h' + ; 'i' + ; 'j' + ; 'k' + ; 'l' + ; 'm' + ; 'n' + ; 'o' + ; 'p' + ; 'q' + ; 'r' + ; 's' + ; 't' + ; 'u' + ; 'v' + ; 'w' + ; 'x' + ; 'y' + ; 'z' + ; 'A' + ; 'B' + ; 'C' + ; 'D' + ; 'E' + ; 'F' + ; 'G' + ; 'H' + ; 'I' + ; 'J' + ; 'K' + ; 'L' + ; 'M' + ; 'N' + ; 'O' + ; 'P' + ; 'Q' + ; 'R' + ; 'S' + ; 'T' + ; 'U' + ; 'V' + ; 'W' + ; 'X' + ; 'Y' + ; 'Z' + ; '0' + ; '1' + ; '2' + ; '3' + ; '4' + ; '5' + ; '6' + ; '7' + ; '8' + ; '9' + ] + in + Gen.oneof (List.map Gen.return printable_chars) +;; + +(* Identifier generator with reserved words check *) +let reserved = + [ "true" + ; "false" + ; "if" + ; "else" + ; "while" + ; "public" + ; "static" + ; "void" + ; "string" + ; "char" + ; "int" + ; "bool" + ; "for" + ; "null" + ; "new" + ; "return" + ; "break" + ; "continue" + ; "class" + ; "async" + ; "await" + ] +;; + +let gen_ident = + let gen_first_char = Gen.char_range 'a' 'z' in + let gen_rest = Gen.list_size (Gen.int_bound 8) gen_ident_char in + let gen_name = + Gen.map2 + (fun first rest -> + let chars = first :: rest in + let buf = Buffer.create 10 in + List.iter (Buffer.add_char buf) chars; + Buffer.contents buf) + gen_first_char + gen_rest + in + Gen.map (fun name -> if List.mem name reserved then Id "x" else Id name) gen_name +;; + +(* =========================================================================== *) +(* Types and values *) +(* =========================================================================== *) + +let gen_base_type = + Gen.oneof [ return TypeInt; return TypeChar; return TypeBool; return TypeString ] +;; + +let gen_full_type = + Gen.oneof [ Gen.map (fun bt -> TypeBase bt) gen_base_type; return TypeVoid ] +;; + +let gen_modifier = Gen.oneof [ return MPublic; return MStatic; return MAsync ] +let gen_modifiers = Gen.(list_size (0 -- 2) gen_modifier) + +(* =========================================================================== *) +(* Expression generator with type support *) +(* =========================================================================== *) + +type type_env = + { variables : (ident * _type) list + ; functions : (ident * (_type list * _type)) list + ; depth : int + } + +let empty_env = { variables = []; functions = []; depth = 3 } + +let gen_safe_string = + Gen.map + (fun chars -> String.of_seq (List.to_seq chars)) + (Gen.list_size (Gen.int_bound 10) gen_safe_char) +;; + +(* =========================================================================== *) +(* Expression generator (full, including assignments) *) +(* =========================================================================== *) + +let rec gen_expr env expected_type = + if env.depth <= 0 + then gen_base_expr env expected_type + else ( + let env' = { env with depth = env.depth - 1 } in + match expected_type with + | TypeVoid -> + (* For void with non-zero depth try calling functions *) + (match env.functions with + | [] -> gen_base_expr env expected_type + | _ -> gen_funcall env' TypeVoid) + | TypeBase _ -> + Gen.oneof_weighted + [ 3, gen_binop_expr env' expected_type + ; 2, gen_unop_expr env' expected_type + ; 2, gen_funcall env' expected_type + ; 1, gen_id_expr env expected_type + ]) + +and gen_expr_no_assign env expected_type = + if env.depth <= 0 + then gen_base_expr_no_assign env expected_type + else ( + let env' = { env with depth = env.depth - 1 } in + match expected_type with + | TypeVoid -> + (* For void with non-zero depth try calling functions *) + (match env.functions with + | [] -> gen_base_expr_no_assign env expected_type + | _ -> gen_funcall env' TypeVoid) + | TypeBase _ -> + Gen.oneof_weighted + [ 3, gen_binop_expr_no_assign env' expected_type + ; 2, gen_unop_expr_no_assign env' expected_type + ; 2, gen_funcall env' expected_type + ; 1, gen_id_expr_no_assign env expected_type + ]) + +(* Base expressions for shallow depth *) +and gen_base_expr env = function + | TypeBase TypeInt -> + Gen.oneof_weighted + [ 4, Gen.map (fun i -> EValue (ValInt i)) (int_bound 100) + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeBool -> + Gen.oneof_weighted + [ 4, Gen.map (fun b -> EValue (ValBool b)) bool + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeChar -> + Gen.oneof_weighted + [ 4, Gen.map (fun c -> EValue (ValChar c)) gen_printable_char + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeString -> + Gen.oneof_weighted + [ 4, Gen.map (fun s -> EValue (ValString s)) gen_safe_string + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeVoid -> + (* For void always generate assignment *) + Gen.( + gen_base_type + >>= fun typ -> + gen_ident + >>= fun id -> + let var_type = TypeBase typ in + gen_expr_no_assign env var_type >>= fun e -> return (EBinOp (OpAssign, EId id, e))) + +(* Identifier generator with type awareness *) +and gen_id_expr env expected_type = + match expected_type with + | TypeBase _ -> + let vars_of_type = List.filter (fun (_, t) -> t = expected_type) env.variables in + (match vars_of_type with + | [] -> + (* If no variables of required type, generate a new one with correct type *) + Gen.map (fun id -> EId id) gen_ident + | vars -> + let var_ids = List.map fst vars in + Gen.oneof (List.map (fun id -> Gen.return (EId id)) var_ids)) + | TypeVoid -> + (* For void always generate assignment *) + Gen.( + gen_base_type + >>= fun typ -> + gen_ident + >>= fun id -> + let var_type = TypeBase typ in + gen_expr_no_assign env var_type >>= fun e -> return (EBinOp (OpAssign, EId id, e))) + +(* Binary operations *) +and gen_binop_expr env expected_type = + match expected_type with + | TypeBase TypeInt -> + let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in + let op_gen = Gen.oneof (List.map return int_ops) in + Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + op_gen + (gen_expr env (TypeBase TypeInt)) + (gen_expr env (TypeBase TypeInt)) + | TypeBase TypeBool -> + let comparison_ops = + [ OpEqual; OpNonEqual; OpLess; OpMore; OpLessEqual; OpMoreEqual ] + in + let logical_ops = [ OpAnd; OpOr ] in + Gen.oneof_weighted + [ ( 2 + , Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return comparison_ops)) + (gen_expr env (TypeBase TypeInt)) + (gen_expr env (TypeBase TypeInt)) ) + ; ( 1 + , Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return logical_ops)) + (gen_expr env (TypeBase TypeBool)) + (gen_expr env (TypeBase TypeBool)) ) + ] + | TypeBase TypeChar | TypeBase TypeString -> + (* For char and string only comparison *) + let comp_ops = [ OpEqual; OpNonEqual ] in + Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return comp_ops)) + (gen_expr env expected_type) + (gen_expr env expected_type) + | TypeVoid -> gen_expr env TypeVoid + +(* Unary operations *) +and gen_unop_expr env expected_type = + match expected_type with + | TypeBase TypeBool -> + Gen.map2 (fun op e -> EUnOp (op, e)) (return OpNot) (gen_expr env (TypeBase TypeBool)) + | TypeBase TypeInt -> + Gen.oneof_weighted + [ ( 2 + , Gen.map2 + (fun op e -> EUnOp (op, e)) + (return OpNeg) + (gen_expr env (TypeBase TypeInt)) ) + ; ( 1 + , Gen.map2 + (fun op id -> EUnOp (op, EId id)) + (Gen.oneof [ return OpNot; return OpNeg ]) + gen_ident ) + ] + | _ -> gen_expr env expected_type + +(* Function calls *) +and gen_funcall env expected_type = + let funcs_of_type = + List.filter (fun (_, (_, ret)) -> ret = expected_type) env.functions + in + match funcs_of_type with + | [] -> gen_base_expr env expected_type + | funcs_list -> + let gen_func = Gen.oneof (List.map (fun (id, _) -> return (EId id)) funcs_list) in + Gen.map2 + (fun f args -> EFuncCall (f, Args args)) + gen_func + (gen_args env expected_type) + +and gen_args env expected_type = + Gen.(int_bound 2 >>= fun count -> list_size (return count) (gen_expr env expected_type)) + +(* =========================================================================== *) +(* Expression generator WITHOUT assignments (for initializers) *) +(* =========================================================================== *) + +(* Base expressions WITHOUT assignments for shallow depth *) +and gen_base_expr_no_assign _ = function + | TypeBase TypeInt -> + Gen.oneof_weighted + [ 4, Gen.map (fun i -> EValue (ValInt i)) (int_bound 100) + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeBool -> + Gen.oneof_weighted + [ 4, Gen.map (fun b -> EValue (ValBool b)) bool + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeChar -> + Gen.oneof_weighted + [ 4, Gen.map (fun c -> EValue (ValChar c)) gen_printable_char + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeBase TypeString -> + Gen.oneof_weighted + [ 4, Gen.map (fun s -> EValue (ValString s)) gen_safe_string + ; 1, Gen.map (fun id -> EId id) gen_ident + ] + | TypeVoid -> + (* For void at zero depth - use existing variables + or create new ones through declarations in gen_decl_stmt *) + Gen.oneof + [ Gen.map (fun id -> EId id) gen_ident + ; Gen.map (fun i -> EValue (ValInt i)) (int_bound 100) + ; Gen.map (fun b -> EValue (ValBool b)) bool + ; Gen.map (fun c -> EValue (ValChar c)) gen_printable_char + ; Gen.map (fun s -> EValue (ValString s)) gen_safe_string + ] + +(* Identifier generator with type awareness (no assignments) *) +and gen_id_expr_no_assign env expected_type = + match expected_type with + | TypeBase _ -> + let vars_of_type = List.filter (fun (_, t) -> t = expected_type) env.variables in + (match vars_of_type with + | [] -> + (* If no variables of required type, generate a value *) + gen_base_expr_no_assign env expected_type + | vars -> + let var_ids = List.map fst vars in + Gen.oneof (List.map (fun id -> Gen.return (EId id)) var_ids)) + | TypeVoid -> + (* For void generate a value *) + gen_base_expr_no_assign env TypeVoid + +(* Unary operations without assignment *) +and gen_unop_expr_no_assign env expected_type = + match expected_type with + | TypeBase TypeBool -> + Gen.map2 + (fun op e -> EUnOp (op, e)) + (return OpNot) + (gen_expr_no_assign env (TypeBase TypeBool)) + | TypeBase TypeInt -> + Gen.oneof_weighted + [ ( 2 + , Gen.map2 + (fun op e -> EUnOp (op, e)) + (return OpNeg) + (gen_expr_no_assign env (TypeBase TypeInt)) ) + ; ( 1 + , Gen.map2 + (fun op id -> EUnOp (op, EId id)) + (Gen.oneof [ return OpNot; return OpNeg ]) + gen_ident ) + ] + | _ -> gen_expr_no_assign env expected_type + +(* Binary operations without assignment *) +and gen_binop_expr_no_assign env expected_type = + match expected_type with + | TypeBase TypeInt -> + let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in + let op_gen = Gen.oneof (List.map return int_ops) in + Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + op_gen + (gen_expr_no_assign env (TypeBase TypeInt)) + (gen_expr_no_assign env (TypeBase TypeInt)) + | TypeBase TypeBool -> + let comparison_ops = + [ OpEqual; OpNonEqual; OpLess; OpMore; OpLessEqual; OpMoreEqual ] + in + let logical_ops = [ OpAnd; OpOr ] in + Gen.oneof_weighted + [ ( 2 + , Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return comparison_ops)) + (gen_expr_no_assign env (TypeBase TypeInt)) + (gen_expr_no_assign env (TypeBase TypeInt)) ) + ; ( 1 + , Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return logical_ops)) + (gen_expr_no_assign env (TypeBase TypeBool)) + (gen_expr_no_assign env (TypeBase TypeBool)) ) + ] + | TypeBase TypeChar | TypeBase TypeString -> + let comp_ops = [ OpEqual; OpNonEqual ] in + Gen.map3 + (fun op l r -> EBinOp (op, l, r)) + (Gen.oneof (List.map return comp_ops)) + (gen_expr_no_assign env expected_type) + (gen_expr_no_assign env expected_type) + | TypeVoid -> gen_expr_no_assign env TypeVoid +;; + +(* =========================================================================== *) +(* Type for assignment result *) +(* =========================================================================== *) + +type assign_result = + | AssignExpr of expr + | AssignBlock of stmt + +(* =========================================================================== *) +(* Statement generator *) +(* =========================================================================== *) + +let rec gen_stmt env return_type = + if env.depth <= 0 + then gen_simple_stmt env return_type + else ( + let env' = { env with depth = env.depth - 1 } in + Gen.oneof_weighted + [ 2, gen_decl_stmt env' + ; 2, gen_expr_stmt env' + ; 2, gen_if_stmt env' return_type + ; 2, gen_while_stmt env' return_type + ; 1, gen_for_stmt env' return_type + ; 1, gen_return_stmt env' return_type + ; 1, gen_block_stmt env' return_type + ; 1, gen_break_continue_stmt + ]) + +and gen_simple_stmt env return_type = + Gen.oneof [ gen_decl_stmt env; gen_expr_stmt env; gen_return_stmt env return_type ] + +and gen_decl_stmt env = + Gen.( + gen_base_type + >>= fun typ -> + gen_ident + >>= fun id -> + (* Generate initializer of correct type WITHOUT assignments *) + let expr_gen = + match typ with + | TypeInt -> gen_expr_no_assign env (TypeBase TypeInt) + | TypeChar -> gen_expr_no_assign env (TypeBase TypeChar) + | TypeBool -> gen_expr_no_assign env (TypeBase TypeBool) + | TypeString -> gen_expr_no_assign env (TypeBase TypeString) + in + (* Always generate an initializer *) + expr_gen + >>= fun init_expr -> + (* Add variable to environment (for subsequent statements) *) + let new_var = id, TypeBase typ in + let _ = { env with variables = new_var :: env.variables } in + return (SDecl (Var (TypeVar (TypeBase typ), id), Some init_expr))) + +(* Assignment generator *) +and gen_assign_expr env : assign_result Gen.t = + match env.variables with + | [] -> + (* If no variables, first create a declaration *) + Gen.( + gen_base_type + >>= fun typ -> + gen_ident + >>= fun id -> + let var_type = TypeBase typ in + gen_expr env var_type + >>= fun e -> + return + (AssignBlock + (SBlock + [ SDecl (Var (TypeVar var_type, id), Some e) + ; SExpr (EBinOp (OpAssign, EId id, EId id)) + ]))) + | vars -> + let var_ids = List.map fst vars in + Gen.( + oneof + (List.map + (fun id -> + (* Choose appropriate type for expression *) + let typ = List.assoc id env.variables in + gen_expr env typ + >>= fun e -> return (AssignExpr (EBinOp (OpAssign, EId id, e)))) + var_ids)) + +(* Function call generator with return value ignored *) +and gen_funcall_ignore_return env : expr Gen.t = + let non_void_funcs = List.filter (fun (_, (_, ret)) -> ret <> TypeVoid) env.functions in + match non_void_funcs with + | [] -> + gen_assign_expr env + >>= (function + | AssignExpr e -> Gen.return e + | AssignBlock (SBlock stmts) -> + (* Find expression in block *) + let rec find_expr = function + | [] -> gen_base_expr env (TypeBase TypeInt) + | SExpr e :: _ -> Gen.return e + | _ :: rest -> find_expr rest + in + find_expr stmts + | _ -> gen_base_expr env (TypeBase TypeInt)) + (* fallback *) + | funcs_list -> + Gen.( + oneof + (List.map + (fun (func_id, (param_types, _)) -> + let rec gen_args_for_params params acc = + match params with + | [] -> return (List.rev acc) + | t :: ts -> + (match t with + | TypeBase bt -> + gen_expr env (TypeBase bt) + >>= fun arg -> gen_args_for_params ts (arg :: acc) + | _ -> gen_args_for_params ts acc (* skip unsupported types *)) + in + gen_args_for_params param_types [] + >>= fun args -> return (EFuncCall (EId func_id, Args args))) + funcs_list)) + +(* Expression statements generator *) +and gen_expr_stmt env : stmt Gen.t = + Gen.( + oneof_weighted + [ ( 4 + , gen_assign_expr env + >>= function + | AssignExpr e -> return (SExpr e) + | AssignBlock stmt -> return stmt ) + ; (4, gen_funcall env TypeVoid >>= fun e -> return (SExpr e)) + ; ( 2 + , if + List.length (List.filter (fun (_, (_, ret)) -> ret <> TypeVoid) env.functions) + > 0 + then gen_funcall_ignore_return env >>= fun e -> return (SExpr e) + else + gen_assign_expr env + >>= function + | AssignExpr e -> return (SExpr e) + | AssignBlock stmt -> return stmt ) + ]) + +and gen_if_stmt env return_type = + Gen.map3 + (fun cond then_stmt else_stmt -> SIf (cond, then_stmt, else_stmt)) + (gen_expr env (TypeBase TypeBool)) + (gen_stmt env return_type) + (Gen.option (gen_stmt env return_type)) + +and gen_while_stmt env return_type = + Gen.map2 + (fun cond body -> SWhile (cond, body)) + (gen_expr env (TypeBase TypeBool)) + (gen_loop_body env return_type) + +and gen_for_stmt env return_type = + Gen.( + option (gen_decl_stmt env) + >>= fun init -> + option (gen_expr env (TypeBase TypeBool)) + >>= fun cond -> + (* Increment can only be ++ or -- operations *) + (if cond <> None + then + oneof_weighted [ 2, option (gen_unop_expr env (TypeBase TypeInt)); 1, return None ] + else return None) + >>= fun incr -> + gen_loop_body env return_type >>= fun body -> return (SFor (init, cond, incr, body))) + +and gen_loop_body env return_type = + Gen.oneof_weighted + [ 3, gen_stmt env return_type; 1, return SBreak; 1, return SContinue ] + +and gen_return_stmt env return_type = + match return_type with + | TypeVoid -> return (SReturn None) + | _ -> Gen.map (fun e -> SReturn (Some e)) (gen_expr env return_type) + +and gen_block_stmt env return_type = + Gen.map (fun stmts -> SBlock stmts) (Gen.list_size (1 -- 3) (gen_stmt env return_type)) + +and gen_break_continue_stmt = Gen.oneof [ return SBreak; return SContinue ] + +(* =========================================================================== *) +(* Class and program generators *) +(* =========================================================================== *) + +let rec has_return stmt = + match stmt with + | SReturn _ -> true + | SBlock stmts -> List.exists has_return stmts + | SIf (_, then_stmt, Some else_stmt) -> has_return then_stmt || has_return else_stmt + | SIf (_, then_stmt, None) -> has_return then_stmt + | SWhile (_, body) -> has_return body + | SFor (_, _, _, body) -> has_return body + | _ -> false +;; + +let ensure_return stmt return_type = + if return_type <> TypeVoid && not (has_return stmt) + then ( + let default_return = + match return_type with + | TypeBase TypeInt -> SReturn (Some (EValue (ValInt 0))) + | TypeBase TypeBool -> SReturn (Some (EValue (ValBool false))) + | TypeBase TypeChar -> SReturn (Some (EValue (ValChar 'a'))) + | TypeBase TypeString -> SReturn (Some (EValue (ValString ""))) + | _ -> SReturn None + in + match stmt with + | SBlock stmts -> SBlock (stmts @ [ default_return ]) + | _ -> SBlock [ stmt; default_return ]) + else if return_type = TypeVoid && not (has_return stmt) + then ( + match stmt with + | SBlock stmts -> SBlock stmts + | _ -> stmt) + else stmt +;; + +let gen_param = + Gen.map2 (fun typ id -> Var (TypeVar (TypeBase typ), id)) gen_base_type gen_ident +;; + +let gen_method env depth = + Gen.( + gen_modifiers + >>= fun modifiers -> + gen_full_type + >>= fun return_type -> + gen_ident + >>= fun id -> + (* Generate parameters *) + int_bound 3 + >>= fun param_count -> + list_size (return param_count) gen_param + >>= fun params -> + (* Update environment with parameters *) + let env_with_params = + List.fold_left + (fun env (Var (TypeVar t, id')) -> + { env with variables = (id', t) :: env.variables }) + env + params + in + (* Generate method body considering return type *) + gen_stmt { env_with_params with depth } return_type + >>= fun body -> + (* Check and add return if needed *) + let valid_body = ensure_return body return_type in + return (Method (modifiers, return_type, id, Params params, valid_body))) +;; + +let gen_field env = + Gen.( + gen_modifiers + >>= fun modifiers -> + gen_base_type + >>= fun typ -> + gen_ident + >>= fun id -> + (* Generate initializer of correct type WITHOUT assignments *) + let expr_gen = + match typ with + | TypeInt -> gen_expr_no_assign { env with depth = 1 } (TypeBase TypeInt) + | TypeChar -> gen_expr_no_assign { env with depth = 1 } (TypeBase TypeChar) + | TypeBool -> gen_expr_no_assign { env with depth = 1 } (TypeBase TypeBool) + | TypeString -> gen_expr_no_assign { env with depth = 1 } (TypeBase TypeString) + in + (* Always generate an initializer *) + expr_gen + >>= fun init -> return (VarField (modifiers, TypeVar (TypeBase typ), id, Some init))) +;; + +let gen_class depth = + let env = { empty_env with depth } in + let rec build_members env acc count = + if count <= 0 + then Gen.return (List.rev acc, env) + else + Gen.( + bool + >>= fun is_field -> + if is_field + then gen_field env >>= fun field -> build_members env (field :: acc) (count - 1) + else + gen_method env depth + >>= fun meth -> + match meth with + | Method (_, ret_type, id, Params params, _) -> + let param_types = List.map (fun (Var (TypeVar t, _)) -> t) params in + let env' = + { env with functions = (id, (param_types, ret_type)) :: env.functions } + in + build_members env' (meth :: acc) (count - 1) + | _ -> build_members env (meth :: acc) (count - 1)) + in + Gen.( + int_range 1 3 + >>= fun member_count -> + build_members env [] member_count + >>= fun (members, _) -> + gen_modifiers + >>= fun modifiers -> gen_ident >>= fun id -> return (Class (modifiers, id, members))) +;; + +let gen_program depth = Gen.map (fun cls -> Program cls) (gen_class depth) + +(* =========================================================================== *) +(* Helper functions *) +(* =========================================================================== *) + +let expr_to_code_string expr = Format.asprintf "%a" Prettyprinter.pp_expr expr +let program_to_code_string prog = Format.asprintf "%a" Prettyprinter.pp_prog prog + +let compare_expr_structure e1 e2 = + match e1, e2 with + | EValue v1, EValue v2 -> + (match v1, v2 with + | ValInt _, ValInt _ + | ValChar _, ValChar _ + | ValBool _, ValBool _ + | ValString _, ValString _ + | ValNull, ValNull -> true + | _ -> false) + | EId _, EId _ -> true + | EBinOp (op1, _, _), EBinOp (op2, _, _) -> op1 = op2 + | EUnOp (op1, _), EUnOp (op2, _) -> op1 = op2 + | EFuncCall (_, Args a1), EFuncCall (_, Args a2) -> List.length a1 = List.length a2 + | _ -> false +;; + +(* =========================================================================== *) +(* QCheck generators *) +(* =========================================================================== *) + +let test_count = 200 + +let expr_arbitrary depth = + let env = { empty_env with depth } in + let gen = + Gen.oneof + [ gen_expr env (TypeBase TypeInt) + ; gen_expr env (TypeBase TypeBool) + ; gen_expr env (TypeBase TypeChar) + ; gen_expr env (TypeBase TypeString) + ; gen_expr env TypeVoid + ] + in + QCheck.make ~print:show_expr gen +;; + +let program_arbitrary depth = QCheck.make ~print:show_program (gen_program depth) + +(* =========================================================================== *) +(* Tests *) +(* =========================================================================== *) + +let prop_roundtrip_expr = + Test.make + ~name:"Expression roundtrip: show -> parse -> show" + ~count:test_count + (expr_arbitrary 2) + (fun expr -> + let code_str = expr_to_code_string expr in + match + Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str + with + | Ok expr' -> + let code_str' = expr_to_code_string expr' in + if code_str = code_str' + then true + else ( + Format.eprintf + "\n\ + @[Expression roundtrip failed:@ Input AST: %s@ Output code: %s@ Parsed \ + back AST: %s@ Final code: %s@]" + (show_expr expr) + code_str + (show_expr expr') + code_str'; + false) + | Error e -> + Format.eprintf + "\n@[Expression parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" + (show_expr expr) + code_str + e; + false) +;; + +let prop_roundtrip_program = + Test.make + ~name:"Program roundtrip: show -> parse -> show" + ~count:test_count + (program_arbitrary 1) + (fun prog -> + let code_str = program_to_code_string prog in + match + Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_prog code_str + with + | Ok prog' -> + let code_str' = program_to_code_string prog' in + if code_str = code_str' + then true + else ( + Format.eprintf + "\n\ + @[Program roundtrip failed:@ Input AST: %s@ Output code: %s@ Parsed \ + back AST: %s@ Final code: %s@]" + (show_program prog) + code_str + (show_program prog') + code_str'; + false) + | Error e -> + Format.eprintf + "\n@[Program parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" + (show_program prog) + code_str + e; + false) +;; + +let prop_operator_precedence = + Test.make + ~name:"Operator precedence is preserved" + ~count:test_count + (expr_arbitrary 2) + (fun expr -> + let code_str = expr_to_code_string expr in + match + Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str + with + | Ok expr' -> + if compare_expr_structure expr expr' + then true + else ( + Format.eprintf + "\n\ + @[Precedence failed:@ Original AST: %s@ Original code: %s@ Parsed AST: \ + %s@ Types differ@]" + (show_expr expr) + code_str + (show_expr expr'); + false) + | Error e -> + Format.eprintf + "\n\ + @[Precedence test parse failed:@ Expression AST: %s@ Code: %s@ Error: \ + %s@]" + (show_expr expr) + code_str + e; + false) +;; + +let prop_parse_errors = + let gen_invalid = + Gen.oneof + [ return "??" + ; return "+++" + ; return "()" + ; return ".;" + ; return "===" + ; return "!" + ; return "&" + ; return "|" + ; return "*" + ; return "/" + ; return "class" + ; return "if" + ; return "while" + ] + in + Test.make + ~name:"Parser returns error on invalid input" + ~count:test_count + (QCheck.make ~print:(fun s -> s) gen_invalid) + (fun str -> + match Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops str with + | Error _ -> true + | Ok expr -> + Format.eprintf + "\n\ + @[Parser should have failed but succeeded:@ Input: %s@ Parsed as AST: \ + %s@]" + str + (show_expr expr); + false) +;; + +let prop_parse_no_crash = + Test.make + ~name:"Parser does not crash on valid expressions" + ~count:test_count + (expr_arbitrary 2) + (fun expr -> + let code_str = expr_to_code_string expr in + match + Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str + with + | Ok _ -> true + | Error e -> + Format.eprintf + "\n\ + @[Parser failed on valid expression (not a crash):@ Input AST: %s@ \ + Generated code: %s@ Error: %s@]" + (show_expr expr) + code_str + e; + true) +;; + +(* =========================================================================== *) +(* Test runner with command line argument handling *) +(* =========================================================================== *) + +let tests = + [ prop_parse_no_crash + ; prop_roundtrip_expr + ; prop_operator_precedence + ; prop_roundtrip_program + ; prop_parse_errors + ] +;; + +(* Function to run tests *) +let run () = QCheck_base_runner.run_tests ~verbose:true tests + +(* Command line argument handling and execution *) +let () = + Arg.parse + [ "--seed", Arg.Int QCheck_base_runner.set_seed, " Set random seed" ] + (fun _ -> ()) + "Usage: qt_tests.exe [options]"; + let exit_code = run () in + if exit_code <> 0 then exit exit_code +;; + +(* TODO: remove printf for debugging *) From 91667dba63a37c1b10d436cc2badbebe16376564 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sun, 15 Mar 2026 19:24:10 +0300 Subject: [PATCH 74/84] fix: zanuda Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/parser.ml | 2 -- CSharpStrange_Kuznetsov/lib/prettyprinter.ml | 2 +- CSharpStrange_Kuznetsov/tests/dune | 2 +- CSharpStrange_Kuznetsov/tests/qt_tests.ml | 3 +-- 4 files changed, 3 insertions(+), 6 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index f4121a0c..9f69cedc 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -293,9 +293,7 @@ let parse_continue = let parse_block = fix (fun block -> let sc p = p <* skip_semicolons1 in - (* операторы, которые должны заканчиваться ; *) let op_sc p = p <* skip_semicolons in - (* операторы, которые могут не заканчиваться ; *) let body_step = choice ?failure_msg:(Some "Error in some block sentence") diff --git a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml index 7125ffbd..ec2b1c68 100644 --- a/CSharpStrange_Kuznetsov/lib/prettyprinter.ml +++ b/CSharpStrange_Kuznetsov/lib/prettyprinter.ml @@ -72,7 +72,7 @@ let pp_val_type fmt = function | ValChar c -> fprintf fmt "'%c'" c | ValNull -> fprintf fmt "null" | ValBool b -> fprintf fmt "%b" b - | ValString s -> fprintf fmt {|"%s"|} s + | ValString s -> fprintf fmt {|%S|} s ;; let rec pp_expr fmt = function diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index c03e274a..9e8abbae 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -15,7 +15,7 @@ (libraries c_sharp_strange_lib qcheck tests) (preprocess (pps ppx_expect)) - (instrumentation + (instrumentation (backend bisect_ppx))) (cram diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml index e27ddfb8..1dfd64a1 100644 --- a/CSharpStrange_Kuznetsov/tests/qt_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/qt_tests.ml @@ -722,8 +722,7 @@ and gen_break_continue_stmt = Gen.oneof [ return SBreak; return SContinue ] (* Class and program generators *) (* =========================================================================== *) -let rec has_return stmt = - match stmt with +let rec has_return = function | SReturn _ -> true | SBlock stmts -> List.exists has_return stmts | SIf (_, then_stmt, Some else_stmt) -> has_return then_stmt || has_return else_stmt From 7a2c82f59877031bf5316e4f9c2483c5eb8872c3 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sun, 15 Mar 2026 19:27:41 +0300 Subject: [PATCH 75/84] fix: added missing files Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam.template | 3 +++ CSharpStrange_Kuznetsov/tests/qt_tests.mli | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam.template create mode 100644 CSharpStrange_Kuznetsov/tests/qt_tests.mli diff --git a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam.template b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam.template new file mode 100644 index 00000000..0b3494bf --- /dev/null +++ b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam.template @@ -0,0 +1,3 @@ +depexts: [ + [ "mono-complete"] {os-distribution = "ubuntu"} +] diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.mli b/CSharpStrange_Kuznetsov/tests/qt_tests.mli new file mode 100644 index 00000000..6b453b16 --- /dev/null +++ b/CSharpStrange_Kuznetsov/tests/qt_tests.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 7860cdd08bcef623737507175524bd85d0341583 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Sun, 15 Mar 2026 19:41:42 +0300 Subject: [PATCH 76/84] fix: small fix Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam index 40edc1d1..8ad4512b 100644 --- a/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam +++ b/CSharpStrange_Kuznetsov/CSharpStrange_Kuznetsov.opam @@ -36,3 +36,6 @@ build: [ "@doc" {with-doc} ] ] +depexts: [ + [ "mono-complete"] {os-distribution = "ubuntu"} +] From 39564880ffaf3818c3bc05d21ff6c3ddfceabe4c Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 20:59:18 +0300 Subject: [PATCH 77/84] fix(tests): some quick test changes Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/qt_test.t | 6 - CSharpStrange_Kuznetsov/tests/qt_tests.ml | 226 +++++++--------------- 2 files changed, 74 insertions(+), 158 deletions(-) diff --git a/CSharpStrange_Kuznetsov/tests/qt_test.t b/CSharpStrange_Kuznetsov/tests/qt_test.t index 2905aa4a..6eb9fa3c 100644 --- a/CSharpStrange_Kuznetsov/tests/qt_test.t +++ b/CSharpStrange_Kuznetsov/tests/qt_test.t @@ -1,10 +1,4 @@ $ ./qt_tests.exe --seed 42 random seed: 42 - generated error fail pass / total time test name - ✓] 200 0 0 200 / 200 0.0s Parser does not crash on valid expressions - ✓] 200 0 0 200 / 200 0.0s Expression roundtrip: show -> parse -> show - ✓] 200 0 0 200 / 200 0.0s Operator precedence is preserved - roundtrip: show -> parse -> show✓] 200 0 0 200 / 200 0.0s Program roundtrip: show -> parse -> show - ✓] 200 0 0 200 / 200 0.0s Parser returns error on invalid input ================================================================================ success (ran 5 tests) diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml index 1dfd64a1..1234632b 100644 --- a/CSharpStrange_Kuznetsov/tests/qt_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/qt_tests.ml @@ -15,161 +15,83 @@ let gen_alpha = Gen.(oneof [ char_range 'a' 'z'; char_range 'A' 'Z' ]) let gen_digit = Gen.char_range '0' '9' let gen_ident_char = Gen.(oneof [ gen_alpha; gen_digit; return '_' ]) -(* Generator for safe string characters *) -let gen_safe_char = - let safe_chars = - [ 'a' - ; 'b' - ; 'c' - ; 'd' - ; 'e' - ; 'f' - ; 'g' - ; 'h' - ; 'i' - ; 'j' - ; 'k' - ; 'l' - ; 'm' - ; 'n' - ; 'o' - ; 'p' - ; 'q' - ; 'r' - ; 's' - ; 't' - ; 'u' - ; 'v' - ; 'w' - ; 'x' - ; 'y' - ; 'z' - ; 'A' - ; 'B' - ; 'C' - ; 'D' - ; 'E' - ; 'F' - ; 'G' - ; 'H' - ; 'I' - ; 'J' - ; 'K' - ; 'L' - ; 'M' - ; 'N' - ; 'O' - ; 'P' - ; 'Q' - ; 'R' - ; 'S' - ; 'T' - ; 'U' - ; 'V' - ; 'W' - ; 'X' - ; 'Y' - ; 'Z' - ; '0' - ; '1' - ; '2' - ; '3' - ; '4' - ; '5' - ; '6' - ; '7' - ; '8' - ; '9' - ; ' ' - ; '_' - ; '-' - ; '+' - ; '*' - ; '/' - ; '=' - ; '(' - ; ')' - ; '.' - ; ',' - ; ';' - ; ':' - ; '!' - ; '?' - ] - in - Gen.oneof (List.map return safe_chars) +let printable_chars = + [ 'a' + ; 'b' + ; 'c' + ; 'd' + ; 'e' + ; 'f' + ; 'g' + ; 'h' + ; 'i' + ; 'j' + ; 'k' + ; 'l' + ; 'm' + ; 'n' + ; 'o' + ; 'p' + ; 'q' + ; 'r' + ; 's' + ; 't' + ; 'u' + ; 'v' + ; 'w' + ; 'x' + ; 'y' + ; 'z' + ; 'A' + ; 'B' + ; 'C' + ; 'D' + ; 'E' + ; 'F' + ; 'G' + ; 'H' + ; 'I' + ; 'J' + ; 'K' + ; 'L' + ; 'M' + ; 'N' + ; 'O' + ; 'P' + ; 'Q' + ; 'R' + ; 'S' + ; 'T' + ; 'U' + ; 'V' + ; 'W' + ; 'X' + ; 'Y' + ; 'Z' + ; '0' + ; '1' + ; '2' + ; '3' + ; '4' + ; '5' + ; '6' + ; '7' + ; '8' + ; '9' + ] ;; -(* Char generator *) -let gen_printable_char = - let printable_chars = - [ 'a' - ; 'b' - ; 'c' - ; 'd' - ; 'e' - ; 'f' - ; 'g' - ; 'h' - ; 'i' - ; 'j' - ; 'k' - ; 'l' - ; 'm' - ; 'n' - ; 'o' - ; 'p' - ; 'q' - ; 'r' - ; 's' - ; 't' - ; 'u' - ; 'v' - ; 'w' - ; 'x' - ; 'y' - ; 'z' - ; 'A' - ; 'B' - ; 'C' - ; 'D' - ; 'E' - ; 'F' - ; 'G' - ; 'H' - ; 'I' - ; 'J' - ; 'K' - ; 'L' - ; 'M' - ; 'N' - ; 'O' - ; 'P' - ; 'Q' - ; 'R' - ; 'S' - ; 'T' - ; 'U' - ; 'V' - ; 'W' - ; 'X' - ; 'Y' - ; 'Z' - ; '0' - ; '1' - ; '2' - ; '3' - ; '4' - ; '5' - ; '6' - ; '7' - ; '8' - ; '9' - ] - in - Gen.oneof (List.map Gen.return printable_chars) +let safe_chars = + printable_chars + @ [ ' '; '_'; '-'; '+'; '*'; '/'; '='; '('; ')'; '.'; ','; ';'; ':'; '!'; '?' ] ;; +(* Generator for safe string characters *) +let gen_safe_char = Gen.oneof (List.map return safe_chars) + +(* Char generator *) +let gen_printable_char = Gen.oneof (List.map Gen.return printable_chars) + (* Identifier generator with reserved words check *) let reserved = [ "true" @@ -1062,7 +984,7 @@ let tests = ;; (* Function to run tests *) -let run () = QCheck_base_runner.run_tests ~verbose:true tests +let run () = QCheck_base_runner.run_tests tests (* Command line argument handling and execution *) let () = From 36129858741245a6b36d714618f459ffe1c7d9a1 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 20:59:31 +0300 Subject: [PATCH 78/84] fix(REPL): REPL fix Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 25 ++++++++---- CSharpStrange_Kuznetsov/lib/typecheck.ml | 39 ++++++++++++++++--- .../tests/interpret_tests.ml | 12 +++--- .../tests/typecheck_tests.ml | 10 ++--- 4 files changed, 62 insertions(+), 24 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index c529067c..018161fa 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -2,9 +2,12 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open C_sharp_strange_lib.Ast -open C_sharp_strange_lib.Parser -open C_sharp_strange_lib.Interpret +open C_sharp_strange_lib +open Ast +open Parser +open Common +open Typecheck +open Interpret open Printf open Stdio @@ -39,9 +42,15 @@ let () = if opts.dump_parse_tree then print_endline (show_program ast); if opts.eval then ( - match interpret_program ast with - | Ok (Some v) -> exit v - | Ok None -> printf "void\n" - | Error _ -> failwith (sprintf "Interpretation error")) - | Error msg -> failwith (sprintf "Failed to parse file: %s" msg) + match ast with + | Program cls -> + (match typecheck_main cls with + | Some _, Ok _ -> + (match interpret_program ast with + | Ok (Some v) -> exit v + | Ok None -> printf "void\n" + | Error e -> failwith (sprintf "Interpretation error: %s" (show_error e))) + | None, Ok _ -> failwith "Interpretation error: Main method not found" + | _, Error e -> failwith (sprintf "Typecheck error: %s" (show_error e)))) + | Error msg -> failwith (sprintf "Parser error: Failed to parse file: %s" msg) ;; diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index 8009f72d..f547175e 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -105,9 +105,31 @@ let find_memb_from_obj obj_id id = (match find_class_memb b id with | Some memb -> return (Some memb) | None -> - List.find_opt (fun (builtin_id, _) -> equal_ident builtin_id id) builtin_methods - |> Option.map (fun (_, info) -> TCMethod info) - |> return) + read_global_el obj_id + >>= (function + | TCClass (Class (_, _, fields)) -> + let static_fields = + List.filter_map + (function + | VarField (mods, typ, fid, init) + when List.exists + (function + | MStatic -> true + | _ -> false) + mods + && equal_ident fid id -> + Some (field_of_ast (VarField (mods, typ, fid, init))) + | _ -> None) + fields + in + (match static_fields with + | [ Ok field_info ] -> return (Some (TCField field_info)) + | _ -> + List.find_opt + (fun (builtin_id, _) -> equal_ident builtin_id id) + builtin_methods + |> Option.map (fun (_, info) -> TCMethod info) + |> return))) ;; let find_memb_type = function @@ -327,12 +349,19 @@ let tc_member mem class_fields = apply_local (let add_field_to_env = function | VarField (mods, field_typ, id, init) -> + let is_static = + List.exists + (function + | MStatic -> true + | _ -> false) + mods + in let field_info = { field_modifiers = mods ; field_type = field_typ ; field_name = id ; field_init = init - ; is_static = false + ; is_static } in write_local_el id (TCField field_info) @@ -349,7 +378,7 @@ let tc_member mem class_fields = if m.is_main then ( let is_valid_signature = - mds = [ MStatic ] + mds = [ MPublic; MStatic ] && pms = Params [] && match tp with diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index 9ebb4fbb..4a7b3f33 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -28,7 +28,7 @@ let%expect_test "Main 1" = static char h = 'a'; static bool t; - static int Main() { + public static int Main() { a = (50 % 2) + b - c; r = s != "kkkk" && (190%22 == 100 * -2/5); t = (a != b * c) || (a >= b) && (a == c +90); @@ -52,7 +52,7 @@ let%expect_test "Main 2" = {| class Program { static int n = 10; - static int Main() { + public static int Main() { int res = 0; for(int i = 0; i < n; i = i+1) { for(int j = 0; j < i; j = j+1) { @@ -78,7 +78,7 @@ let%expect_test "Main 3" = static bool t; static int a = 5; - static int Main() { + public static int Main() { int b = 5; int c = 2; t = true; @@ -110,7 +110,7 @@ let%expect_test "Main 4" = class Program { static int x = 189; static int s = 0; - static int Main() { + public static int Main() { while (x != 0) { s = s + x % 10; x = x/ 10; @@ -137,7 +137,7 @@ let%expect_test "Functions 1" = return 2; } } - static int Main() { + public static int Main() { System.Console.WriteLine(is_right_triangle(3,4,5)); return; } @@ -160,7 +160,7 @@ let%expect_test "Factorial with writeline" = return num * Fac(num - 1); } } - static int Main() { + public static int Main() { int result = Fac(5); System.Console.WriteLine(result); return result; diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index d598254c..5632a611 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -31,7 +31,7 @@ let%expect_test "Factorial" = return num * Fac(num - 1); } } - static int Main() { + public static int Main() { return Fac(5); } } |}; @@ -72,7 +72,7 @@ let%expect_test "Invalid value" = test_typecheck {| class Program { - static int Main() { + public static int Main() { int a; int b = a -1 + 4; return b; @@ -124,7 +124,7 @@ let%expect_test "While" = test_typecheck {| class Program { - static int Main() { + public static int Main() { int count = 0; bool b = true; while(true) { @@ -152,7 +152,7 @@ let%expect_test "For" = class Program { int n = 10; int count = 7% 2*67; - static int Main() { + public static int Main() { for (int i = 0; i < n; i=i+1) { for (int j = 1;;) { for (;j != n; j = j + 2) { @@ -222,7 +222,7 @@ let%expect_test "Factorial with writeline" = return num * Fac(num - 1); } } - static int Main() { + public static int Main() { int result = Fac(5); System.Console.WriteLine(result); return result; From 5f7f40ceb09311ce9b818707180516baf75cfd21 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 21:05:35 +0300 Subject: [PATCH 79/84] docs: added docstrings for some ADTs Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/common.ml | 29 +++++++++++++++--------- CSharpStrange_Kuznetsov/lib/interpret.ml | 13 ++++++----- 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/common.ml b/CSharpStrange_Kuznetsov/lib/common.ml index f04dff35..ff6fdfdf 100644 --- a/CSharpStrange_Kuznetsov/lib/common.ml +++ b/CSharpStrange_Kuznetsov/lib/common.ml @@ -4,28 +4,35 @@ open Ast +(** Type checking errors *) type tc_error = - | NotImplemented + | NotImplemented (** Feature not implemented in the type checker *) | OccursCheck + (** Occurs check failed during type unification (typically for recursive types) *) | AccessError + (** Invalid access to a member (e.g., accessing private member from outside) *) | ImpossibleResult of string - | TypeMismatch - | OtherError of string + (** Type checking encountered an impossible state with additional context *) + | TypeMismatch (** Expected type does not match actual type *) + | OtherError of string (** Other type checking error with description *) [@@deriving show { with_path = false }] +(** Runtime interpretation errors *) type interpret_error = - | NotImplemented - | NoVariable of string - | AddressNotFound of int - | VarDeclared of string - | TypeMismatch + | NotImplemented (** Feature not implemented in the interpreter *) + | NoVariable of string (** Variable not found in current scope *) + | AddressNotFound of int (** Memory address not found in store *) + | VarDeclared of string (** Variable already declared in current scope *) + | TypeMismatch (** Type mismatch during runtime operation *) | ImpossibleResult of string - | OtherError of string + (** Interpreter encountered an impossible state with additional context *) + | OtherError of string (** Other runtime error with description *) [@@deriving show { with_path = false }] +(** Union type for all possible errors *) type error = - | TCError of tc_error - | IError of interpret_error + | TCError of tc_error (** Type checking error *) + | IError of interpret_error (** Runtime interpretation error *) [@@deriving show { with_path = false }] module Id = struct diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 2fa4a6ec..17870a72 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -21,13 +21,14 @@ module IdMap = Map.Make (struct module LocMap = Map.Make (Int) +(** Runtime values during interpretation *) type value = - | VInt of int - | VBool of bool - | VChar of char - | VString of string - | VNull - | VObject of adr + | VInt of int (** Integer value (corresponds to C# int) *) + | VBool of bool (** Boolean value (corresponds to C# bool) *) + | VChar of char (** Character value (corresponds to C# char) *) + | VString of string (** String value (corresponds to C# string) *) + | VNull (** Null reference (corresponds to C# null) *) + | VObject of adr (** Object reference stored at given address in memory *) [@@deriving show { with_path = false }] type func = From c715bb8d586c3426f4b17f92d1c202567c3ccfd4 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 21:16:29 +0300 Subject: [PATCH 80/84] fix(typecheck): break & continue Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/typecheck.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index f547175e..d6211bf6 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -11,7 +11,7 @@ let value_to_type = function | ValChar _ -> TypeBase TypeChar | ValBool _ -> TypeBase TypeBool | ValString _ -> TypeBase TypeString - | ValNull -> TypeBase TypeInt (* TODO separately? *) + | ValNull -> TypeBase TypeInt ;; let string_of_ident (Id s) = s @@ -83,13 +83,12 @@ let get_class_memb id memb = ;; let builtin_methods = - (* TODO: запрет для других функций с точкой/ начальный namespace ? *) [ ( Id "System.Console.WriteLine" , { method_modifiers = [ MStatic ] ; method_return = TypeVoid ; method_name = Id "System.Console.WriteLine" ; method_params = Params [ Var (TypeVar (TypeBase TypeInt), Id "value") ] - ; method_body = SBlock [] (* TODO: making definition here? *) + ; method_body = SBlock [] ; is_static = true ; is_main = false } ) @@ -216,7 +215,6 @@ let tc_method_invoke e args expr_tc = ;; let check_initialized n = - (* TODO: refactor to locals ?? *) read_local_el n >>= function | TCLocalVar v when v.initialized -> return () @@ -327,7 +325,7 @@ let rec tc_stmt = | SFor (init, cond, iter, b) -> apply_local (tc_for_state init cond iter *> tc_stmt b) | SIf (e, b, s_opt) -> apply_local (tc_if_state e b s_opt tc_stmt) | SBlock st_l -> apply_local (iter tc_stmt st_l) - | SBreak | SContinue -> fail (TCError NotImplemented) + | SBreak | SContinue -> return () (* Will check execution in interpreter *) ;; (* TODO Break TC *) From b376ef54c5825409917d5aa97647a32292be9781 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 21:26:37 +0300 Subject: [PATCH 81/84] chore: removed TODOs Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/lib/interpret.ml | 18 +------ CSharpStrange_Kuznetsov/lib/parser.ml | 4 -- CSharpStrange_Kuznetsov/lib/typecheck.ml | 4 -- .../tests/interpret_tests.ml | 11 ---- CSharpStrange_Kuznetsov/tests/parser_tests.ml | 6 +-- CSharpStrange_Kuznetsov/tests/pp_tests.ml | 52 ++++--------------- CSharpStrange_Kuznetsov/tests/qt_tests.ml | 31 ++--------- .../tests/typecheck_tests.ml | 50 ------------------ 8 files changed, 15 insertions(+), 161 deletions(-) diff --git a/CSharpStrange_Kuznetsov/lib/interpret.ml b/CSharpStrange_Kuznetsov/lib/interpret.ml index 17870a72..c1c77496 100644 --- a/CSharpStrange_Kuznetsov/lib/interpret.ml +++ b/CSharpStrange_Kuznetsov/lib/interpret.ml @@ -6,7 +6,6 @@ open Ast open Parser open Common open Typecheck -(* TODO: monad refactoring *) let ( let* ) = Result.bind let return x = Ok x @@ -59,7 +58,6 @@ type object_state = ; fields : (ident * field_value) list } -(*TODO name?*) type class_def = { fields : (ident * _type * expr option * bool) list ; methods : (ident * func) list @@ -78,7 +76,6 @@ type runtime = type return_code = int (* Printers *) -(* TODO: not need pp? *) let pp_value fmt = function | VInt i -> Format.fprintf fmt "%d" i | VBool b -> Format.fprintf fmt "%b" b @@ -593,9 +590,7 @@ let init_program (Class (_, name, fields)) = let class_def = class_of_ast (Class ([], name, fields)) in let rt = { empty_runtime with class_def = Some class_def } in let builtin_functions = - [ Id "System.Console.WriteLine", { params = [ Id "value" ]; body = SBlock [] } - (* TODO: change from call_function and typecheck to some common space *) - ] + [ Id "System.Console.WriteLine", { params = [ Id "value" ]; body = SBlock [] } ] in let rt_with_builtins = List.fold_left @@ -651,14 +646,3 @@ let interpret str = | Some _, Ok _ -> interpret_program (Program prog) | None, Ok _ -> Error (TCError (OtherError "Main method not found"))) ;; - -(* TODO: error messages? *) -(* -Quicktests for parser - TODO: lambdas + closures - arrays (1D) + new - - pre/post increment/decrement - LINQ (simple array queries) - async/await (at least without lambdas) -*) diff --git a/CSharpStrange_Kuznetsov/lib/parser.ml b/CSharpStrange_Kuznetsov/lib/parser.ml index 9f69cedc..f5f97860 100644 --- a/CSharpStrange_Kuznetsov/lib/parser.ml +++ b/CSharpStrange_Kuznetsov/lib/parser.ml @@ -51,7 +51,6 @@ let is_space = function ;; let is_token_sym = function - (* TODO: think about . (could be initial namespace) *) | 'a' .. 'z' | '0' .. '9' | 'A' .. 'Z' | '.' | '_' -> true | _ -> false ;; @@ -201,7 +200,6 @@ let parse_ops = let appl op = op in lv1 >>= fun e -> return (List.fold_right ops ~f:appl ~init:e) in - (* TODO: rewrite somehow + more ops *) let lv3 = chainl1 lv2 (choice [ ( ^*^ ); ( ^/^ ); ( ^%^ ) ]) in let lv4 = chainl1 lv3 (choice [ ( ^+^ ); ( ^-^ ) ]) in let lv5 = chainl1 lv4 (choice [ ( ^<=^ ); ( ^>=^ ); ( ^<^ ); ( ^>^ ) ]) in @@ -380,5 +378,3 @@ let parse_option p str = | Ok x -> Some x | Error _ -> None ;; - -(* TODO: lambda parsing??? *) diff --git a/CSharpStrange_Kuznetsov/lib/typecheck.ml b/CSharpStrange_Kuznetsov/lib/typecheck.ml index d6211bf6..1bce17e6 100644 --- a/CSharpStrange_Kuznetsov/lib/typecheck.ml +++ b/CSharpStrange_Kuznetsov/lib/typecheck.ml @@ -328,8 +328,6 @@ let rec tc_stmt = | SBreak | SContinue -> return () (* Will check execution in interpreter *) ;; -(* TODO Break TC *) - let tc_member mem class_fields = let tc_class_field f_type = function | Some e -> eq_type_with_expr (vartype_to_type f_type) e *> return () @@ -438,5 +436,3 @@ let tc_obj cl = let typecheck prog = run (tc_obj prog) (IdMap.empty, IdMap.empty, None, None, None) let typecheck_main prog = typecheck prog |> fun ((_, _, _, _, main), res) -> main, res - -(* TODO: unify with interpret *) diff --git a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml index 4a7b3f33..821a7306 100644 --- a/CSharpStrange_Kuznetsov/tests/interpret_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/interpret_tests.ml @@ -14,8 +14,6 @@ let test_interpret str = | Result.Error er -> Format.printf "%a\n%!" pp_error er ;; -(* TODO: include TC? *) - let%expect_test "Main 1" = test_interpret {| @@ -42,11 +40,6 @@ let%expect_test "Main 1" = -58 |}] ;; -(* TODO: Access to non-static fields from static methods is prohibited - Static classes can only have static methods, but static cannot be the program entry point - Maybe add class check inside main, but won't have time -*) - let%expect_test "Main 2" = test_interpret {| @@ -69,8 +62,6 @@ let%expect_test "Main 2" = 870 |}] ;; -(* TODO: n without static *) - let%expect_test "Main 3" = test_interpret {| @@ -170,5 +161,3 @@ let%expect_test "Factorial with writeline" = {| 120 |}] ;; - -(* TODO: non static not allowed *) diff --git a/CSharpStrange_Kuznetsov/tests/parser_tests.ml b/CSharpStrange_Kuznetsov/tests/parser_tests.ml index 268a19b4..e9a912ee 100644 --- a/CSharpStrange_Kuznetsov/tests/parser_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/parser_tests.ml @@ -427,7 +427,7 @@ let%test "Parse factorial" = ] ))) ;; -let%test "parse program with weird whitespace" = +let%test "Short: Parse program with weird whitespace" = let program = {| class Program @@ -448,7 +448,7 @@ let%test "parse program with weird whitespace" = | Error _ -> false ;; -let%test "Parse checking fields" = +let%test "Short: Parse checking fields" = let program = {| class Program { @@ -470,5 +470,3 @@ let%test "Parse checking fields" = | Ok _ -> true | Error _ -> false ;; - -(* TODO: rewrite to normal *) diff --git a/CSharpStrange_Kuznetsov/tests/pp_tests.ml b/CSharpStrange_Kuznetsov/tests/pp_tests.ml index 12fe81bf..7d27f259 100644 --- a/CSharpStrange_Kuznetsov/tests/pp_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/pp_tests.ml @@ -7,22 +7,6 @@ open Prettyprinter open Parser open Format -(* Debug (TODO remove later) -let test_pp name source = - let prog = parse_option parse_prog source in - let pretty = - match prog with - | Some x -> asprintf "%a" pp_prog x - | None -> "" - in - let prog_after_pp = parse_option parse_prog pretty in - if prog = prog_after_pp - then Printf.printf "✓ %s: roundtrip successful\n" name - else Printf.printf "✗ %s: roundtrip failed\n" name; - prog = prog_after_pp -;; -*) - let test_pp _ source = let prog = parse_option parse_prog source in let pretty = @@ -128,7 +112,7 @@ public class Program public static class Program { static int result = 0; - public static void Main(string[] args) { + public static void Main() { int a = 5; int b = 3; result = a + b * 2; @@ -169,7 +153,7 @@ public class Test { public static class Program { static int result = 0; - public static void Main(string[] args) { + public static void Main() { int a = 5; int b = 3; result = a + b * 2; @@ -188,7 +172,7 @@ public static class Program { public static class Program { static int sum = 0; - public static void Main(string[] args) { + public static void Main() { int i = 0; while (i < 5) { @@ -211,7 +195,7 @@ public static class Program { static bool flag = true; static int value = 42; - public static void Main(string[] args) { + public static void Main() { bool condition = flag && (value > 40); if (condition) { @@ -235,7 +219,7 @@ public static class Program { static string message = "Hello"; static char symbol = 'A'; - public static void Main(string[] args) { + public static void Main() { string name = "World"; string result = message + " " + name; @@ -255,7 +239,7 @@ public static class Program { public static class Program { static int counter = 0; - public static void Main(string[] args) { + public static void Main() { for (int i = 0; i < 10; i = i + 1) { if (i == 3) { continue; @@ -285,7 +269,7 @@ public static class Program { static int y = 20; static bool ok = true; - public static void Main(string[] args) { + public static void Main() { int result = (x + y) * (x - y) / 2; bool check = (x > y) && ok || (x <= y); @@ -311,7 +295,7 @@ public static class Program { static char c1 = 'X'; static char c2 = 'Y'; - public static void Main(string[] args) { + public static void Main() { int x = a + b; string text = s1 + s2; bool flag = b1 && b2; @@ -327,7 +311,7 @@ public static class Program { public static class Program { static int value = 100; - public static void Main(string[] args) { + public static void Main() { int a = 5; int b = 3; @@ -361,21 +345,3 @@ public static class Program { let%test "All pp roundtrip tests" = List.for_all (fun (name, source) -> test_pp name source) samples ;; - -(* TODO: check string[] args later!! *) - -(* TODO: simple arrays: - -public static class Program { - static int[] numbers = null; - - public static void Main(string[] args) { - int index = 0; - int value = numbers[index]; - - numbers[index + 1] = value * 2; - - return; - } -} -*) diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qt_tests.ml index 1234632b..1f4582b6 100644 --- a/CSharpStrange_Kuznetsov/tests/qt_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/qt_tests.ml @@ -1,14 +1,13 @@ -(* qt_tests.ml *) -(* TODO: refactor + add to README *) +(** Copyright 2026, Dmitrii Kuznetsov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib open QCheck open Gen open Ast -(* =========================================================================== *) (* Basic generators *) -(* =========================================================================== *) (* Basic characters and strings *) let gen_alpha = Gen.(oneof [ char_range 'a' 'z'; char_range 'A' 'Z' ]) @@ -134,9 +133,7 @@ let gen_ident = Gen.map (fun name -> if List.mem name reserved then Id "x" else Id name) gen_name ;; -(* =========================================================================== *) (* Types and values *) -(* =========================================================================== *) let gen_base_type = Gen.oneof [ return TypeInt; return TypeChar; return TypeBool; return TypeString ] @@ -149,9 +146,7 @@ let gen_full_type = let gen_modifier = Gen.oneof [ return MPublic; return MStatic; return MAsync ] let gen_modifiers = Gen.(list_size (0 -- 2) gen_modifier) -(* =========================================================================== *) (* Expression generator with type support *) -(* =========================================================================== *) type type_env = { variables : (ident * _type) list @@ -167,9 +162,7 @@ let gen_safe_string = (Gen.list_size (Gen.int_bound 10) gen_safe_char) ;; -(* =========================================================================== *) (* Expression generator (full, including assignments) *) -(* =========================================================================== *) let rec gen_expr env expected_type = if env.depth <= 0 @@ -340,9 +333,7 @@ and gen_funcall env expected_type = and gen_args env expected_type = Gen.(int_bound 2 >>= fun count -> list_size (return count) (gen_expr env expected_type)) -(* =========================================================================== *) (* Expression generator WITHOUT assignments (for initializers) *) -(* =========================================================================== *) (* Base expressions WITHOUT assignments for shallow depth *) and gen_base_expr_no_assign _ = function @@ -456,17 +447,13 @@ and gen_binop_expr_no_assign env expected_type = | TypeVoid -> gen_expr_no_assign env TypeVoid ;; -(* =========================================================================== *) (* Type for assignment result *) -(* =========================================================================== *) type assign_result = | AssignExpr of expr | AssignBlock of stmt -(* =========================================================================== *) (* Statement generator *) -(* =========================================================================== *) let rec gen_stmt env return_type = if env.depth <= 0 @@ -640,9 +627,7 @@ and gen_block_stmt env return_type = and gen_break_continue_stmt = Gen.oneof [ return SBreak; return SContinue ] -(* =========================================================================== *) (* Class and program generators *) -(* =========================================================================== *) let rec has_return = function | SReturn _ -> true @@ -764,9 +749,7 @@ let gen_class depth = let gen_program depth = Gen.map (fun cls -> Program cls) (gen_class depth) -(* =========================================================================== *) (* Helper functions *) -(* =========================================================================== *) let expr_to_code_string expr = Format.asprintf "%a" Prettyprinter.pp_expr expr let program_to_code_string prog = Format.asprintf "%a" Prettyprinter.pp_prog prog @@ -788,9 +771,7 @@ let compare_expr_structure e1 e2 = | _ -> false ;; -(* =========================================================================== *) (* QCheck generators *) -(* =========================================================================== *) let test_count = 200 @@ -810,9 +791,7 @@ let expr_arbitrary depth = let program_arbitrary depth = QCheck.make ~print:show_program (gen_program depth) -(* =========================================================================== *) (* Tests *) -(* =========================================================================== *) let prop_roundtrip_expr = Test.make @@ -970,9 +949,7 @@ let prop_parse_no_crash = true) ;; -(* =========================================================================== *) (* Test runner with command line argument handling *) -(* =========================================================================== *) let tests = [ prop_parse_no_crash @@ -995,5 +972,3 @@ let () = let exit_code = run () in if exit_code <> 0 then exit exit_code ;; - -(* TODO: remove printf for debugging *) diff --git a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml index 5632a611..ffbc6853 100644 --- a/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/typecheck_tests.ml @@ -104,8 +104,6 @@ let%expect_test "Checking fields" = Ok! |}] ;; -(* TODO: parser check! *) - let%expect_test "String + int" = test_typecheck {| @@ -118,8 +116,6 @@ let%expect_test "String + int" = (TCError TypeMismatch) |}] ;; -(* TODO: string! *) - let%expect_test "While" = test_typecheck {| @@ -232,49 +228,3 @@ let%expect_test "Factorial with writeline" = {| Ok! |}] ;; - -(* - let%expect_test "Typecheck local variable shadows built-in" = - test_typecheck - {| - public static class Program { - public static int Main() { - int System = 42; - System.Console.WriteLine(10); // Error: System is int - return System; - } - } |}; - [%expect {| (TCError ) |}] -;; - -(* TODO: think about forbidden names *) - -(* 2. Параметр функции перекрывает встроенную функцию *) -let%expect_test "TC: parameter shadows built-in" = - test_typecheck - {| - public class Program { - public static int Print(int Console) { - Console.WriteLine("Hello"); // Error: Console is int - return Console * 2; - } - public static int Main() { - return Print(21); - } - } |}; - [%expect - {| - (TCError - (OtherError "Cannot call a variable as a method")) |}] -;; -(* TODO: parsing error *) -*) - -(* TODO: occurs check test: smth like - {| - class Program { - public void f() { - bool a = new Ob(); - }; - }|} -*) From 31943991f93d7f003ecd079d2da210bae7befe2e Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 21:28:57 +0300 Subject: [PATCH 82/84] chore: renamed qcheck file Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/tests/dune | 8 ++++---- CSharpStrange_Kuznetsov/tests/{qt_test.t => qc_test.t} | 2 +- .../tests/{qt_tests.ml => qc_tests.ml} | 0 .../tests/{qt_tests.mli => qc_tests.mli} | 0 4 files changed, 5 insertions(+), 5 deletions(-) rename CSharpStrange_Kuznetsov/tests/{qt_test.t => qc_test.t} (81%) rename CSharpStrange_Kuznetsov/tests/{qt_tests.ml => qc_tests.ml} (100%) rename CSharpStrange_Kuznetsov/tests/{qt_tests.mli => qc_tests.mli} (100%) diff --git a/CSharpStrange_Kuznetsov/tests/dune b/CSharpStrange_Kuznetsov/tests/dune index 9e8abbae..9d397dd5 100644 --- a/CSharpStrange_Kuznetsov/tests/dune +++ b/CSharpStrange_Kuznetsov/tests/dune @@ -10,8 +10,8 @@ (pps ppx_expect))) (executable - (name qt_tests) - (modules Qt_tests) + (name qc_tests) + (modules Qc_tests) (libraries c_sharp_strange_lib qcheck tests) (preprocess (pps ppx_expect)) @@ -27,5 +27,5 @@ (deps ../bin/REPL.exe ../bin/fib.cs)) (cram - (applies_to qt_test) - (deps qt_tests.exe)) + (applies_to qc_test) + (deps qc_tests.exe)) diff --git a/CSharpStrange_Kuznetsov/tests/qt_test.t b/CSharpStrange_Kuznetsov/tests/qc_test.t similarity index 81% rename from CSharpStrange_Kuznetsov/tests/qt_test.t rename to CSharpStrange_Kuznetsov/tests/qc_test.t index 6eb9fa3c..b6582c42 100644 --- a/CSharpStrange_Kuznetsov/tests/qt_test.t +++ b/CSharpStrange_Kuznetsov/tests/qc_test.t @@ -1,4 +1,4 @@ - $ ./qt_tests.exe --seed 42 + $ ./qc_tests.exe --seed 42 random seed: 42 ================================================================================ success (ran 5 tests) diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.ml b/CSharpStrange_Kuznetsov/tests/qc_tests.ml similarity index 100% rename from CSharpStrange_Kuznetsov/tests/qt_tests.ml rename to CSharpStrange_Kuznetsov/tests/qc_tests.ml diff --git a/CSharpStrange_Kuznetsov/tests/qt_tests.mli b/CSharpStrange_Kuznetsov/tests/qc_tests.mli similarity index 100% rename from CSharpStrange_Kuznetsov/tests/qt_tests.mli rename to CSharpStrange_Kuznetsov/tests/qc_tests.mli From 50605c3b196df00dba638c1748c6e693305e10ad Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 21:58:36 +0300 Subject: [PATCH 83/84] fix: zanuda (removed lints) Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 12 +-- CSharpStrange_Kuznetsov/tests/qc_tests.ml | 93 +++++++---------------- 2 files changed, 34 insertions(+), 71 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 018161fa..6dee6a6c 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -28,7 +28,7 @@ let () = ; "-eval", Arg.Unit (fun () -> opts.eval <- true), "Run interpreter\n" ] (fun _ -> - Stdlib.Format.eprintf "Something got wrong\n"; + let () = Stdlib.Format.eprintf "Something got wrong\n" in Stdlib.exit 1) "\n" in @@ -39,7 +39,7 @@ let () = in match apply_parser parse_prog path with | Ok ast -> - if opts.dump_parse_tree then print_endline (show_program ast); + let () = if opts.dump_parse_tree then print_endline (show_program ast) in if opts.eval then ( match ast with @@ -49,8 +49,8 @@ let () = (match interpret_program ast with | Ok (Some v) -> exit v | Ok None -> printf "void\n" - | Error e -> failwith (sprintf "Interpretation error: %s" (show_error e))) - | None, Ok _ -> failwith "Interpretation error: Main method not found" - | _, Error e -> failwith (sprintf "Typecheck error: %s" (show_error e)))) - | Error msg -> failwith (sprintf "Parser error: Failed to parse file: %s" msg) + | Error e -> printf "Interpretation error: %s" (show_error e)) + | None, Ok _ -> printf "Interpretation error: Main method not found" + | _, Error e -> printf "Typecheck error: %s" (show_error e))) + | Error msg -> printf "Parser error: Failed to parse file: %s" msg ;; diff --git a/CSharpStrange_Kuznetsov/tests/qc_tests.ml b/CSharpStrange_Kuznetsov/tests/qc_tests.ml index 1f4582b6..978b98f2 100644 --- a/CSharpStrange_Kuznetsov/tests/qc_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/qc_tests.ml @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open C_sharp_strange_lib +open Parser open QCheck open Gen open Ast @@ -257,8 +258,7 @@ and gen_id_expr env expected_type = gen_expr_no_assign env var_type >>= fun e -> return (EBinOp (OpAssign, EId id, e))) (* Binary operations *) -and gen_binop_expr env expected_type = - match expected_type with +and gen_binop_expr env = function | TypeBase TypeInt -> let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in let op_gen = Gen.oneof (List.map return int_ops) in @@ -408,8 +408,7 @@ and gen_unop_expr_no_assign env expected_type = | _ -> gen_expr_no_assign env expected_type (* Binary operations without assignment *) -and gen_binop_expr_no_assign env expected_type = - match expected_type with +and gen_binop_expr_no_assign env = function | TypeBase TypeInt -> let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in let op_gen = Gen.oneof (List.map return int_ops) in @@ -575,9 +574,7 @@ and gen_expr_stmt env : stmt Gen.t = | AssignBlock stmt -> return stmt ) ; (4, gen_funcall env TypeVoid >>= fun e -> return (SExpr e)) ; ( 2 - , if - List.length (List.filter (fun (_, (_, ret)) -> ret <> TypeVoid) env.functions) - > 0 + , if List.exists (fun (_, (_, ret)) -> ret <> TypeVoid) env.functions then gen_funcall_ignore_return env >>= fun e -> return (SExpr e) else gen_assign_expr env @@ -800,29 +797,19 @@ let prop_roundtrip_expr = (expr_arbitrary 2) (fun expr -> let code_str = expr_to_code_string expr in - match - Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str - with + match Angstrom.parse_string ~consume:Angstrom.Consume.All parse_ops code_str with | Ok expr' -> let code_str' = expr_to_code_string expr' in - if code_str = code_str' - then true - else ( + code_str = code_str' + | Error e -> + let () = Format.eprintf "\n\ - @[Expression roundtrip failed:@ Input AST: %s@ Output code: %s@ Parsed \ - back AST: %s@ Final code: %s@]" + @[Expression parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" (show_expr expr) code_str - (show_expr expr') - code_str'; - false) - | Error e -> - Format.eprintf - "\n@[Expression parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" - (show_expr expr) - code_str - e; + e + in false) ;; @@ -833,29 +820,18 @@ let prop_roundtrip_program = (program_arbitrary 1) (fun prog -> let code_str = program_to_code_string prog in - match - Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_prog code_str - with + match Angstrom.parse_string ~consume:Angstrom.Consume.All parse_prog code_str with | Ok prog' -> let code_str' = program_to_code_string prog' in - if code_str = code_str' - then true - else ( + code_str = code_str' + | Error e -> + let () = Format.eprintf - "\n\ - @[Program roundtrip failed:@ Input AST: %s@ Output code: %s@ Parsed \ - back AST: %s@ Final code: %s@]" + "\n@[Program parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" (show_program prog) code_str - (show_program prog') - code_str'; - false) - | Error e -> - Format.eprintf - "\n@[Program parse failed:@ Input AST: %s@ Output code: %s@ Error: %s@]" - (show_program prog) - code_str - e; + e + in false) ;; @@ -866,29 +842,18 @@ let prop_operator_precedence = (expr_arbitrary 2) (fun expr -> let code_str = expr_to_code_string expr in - match - Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str - with - | Ok expr' -> - if compare_expr_structure expr expr' - then true - else ( + match Angstrom.parse_string ~consume:Angstrom.Consume.All parse_ops code_str with + | Ok expr' -> compare_expr_structure expr expr' + | Error e -> + let () = Format.eprintf "\n\ - @[Precedence failed:@ Original AST: %s@ Original code: %s@ Parsed AST: \ - %s@ Types differ@]" + @[Precedence test parse failed:@ Expression AST: %s@ Code: %s@ Error: \ + %s@]" (show_expr expr) code_str - (show_expr expr'); - false) - | Error e -> - Format.eprintf - "\n\ - @[Precedence test parse failed:@ Expression AST: %s@ Code: %s@ Error: \ - %s@]" - (show_expr expr) - code_str - e; + e + in false) ;; @@ -915,7 +880,7 @@ let prop_parse_errors = ~count:test_count (QCheck.make ~print:(fun s -> s) gen_invalid) (fun str -> - match Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops str with + match Angstrom.parse_string ~consume:Angstrom.Consume.All parse_ops str with | Error _ -> true | Ok expr -> Format.eprintf @@ -934,9 +899,7 @@ let prop_parse_no_crash = (expr_arbitrary 2) (fun expr -> let code_str = expr_to_code_string expr in - match - Angstrom.parse_string ~consume:Angstrom.Consume.All Parser.parse_ops code_str - with + match Angstrom.parse_string ~consume:Angstrom.Consume.All parse_ops code_str with | Ok _ -> true | Error e -> Format.eprintf From c34aa016b1dac81db9462cbe9732ecd5e9de1b50 Mon Sep 17 00:00:00 2001 From: f1i3g3 Date: Mon, 16 Mar 2026 22:03:24 +0300 Subject: [PATCH 84/84] fix: quick fix Signed-off-by: f1i3g3 --- CSharpStrange_Kuznetsov/bin/REPL.ml | 1 - CSharpStrange_Kuznetsov/tests/qc_tests.ml | 10 ++++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/CSharpStrange_Kuznetsov/bin/REPL.ml b/CSharpStrange_Kuznetsov/bin/REPL.ml index 6dee6a6c..c98fc45a 100644 --- a/CSharpStrange_Kuznetsov/bin/REPL.ml +++ b/CSharpStrange_Kuznetsov/bin/REPL.ml @@ -8,7 +8,6 @@ open Parser open Common open Typecheck open Interpret -open Printf open Stdio type opts = diff --git a/CSharpStrange_Kuznetsov/tests/qc_tests.ml b/CSharpStrange_Kuznetsov/tests/qc_tests.ml index 978b98f2..b7fa88f6 100644 --- a/CSharpStrange_Kuznetsov/tests/qc_tests.ml +++ b/CSharpStrange_Kuznetsov/tests/qc_tests.ml @@ -178,7 +178,7 @@ let rec gen_expr env expected_type = | _ -> gen_funcall env' TypeVoid) | TypeBase _ -> Gen.oneof_weighted - [ 3, gen_binop_expr env' expected_type + [ 3, gen_binop_expr expected_type env' ; 2, gen_unop_expr env' expected_type ; 2, gen_funcall env' expected_type ; 1, gen_id_expr env expected_type @@ -197,7 +197,7 @@ and gen_expr_no_assign env expected_type = | _ -> gen_funcall env' TypeVoid) | TypeBase _ -> Gen.oneof_weighted - [ 3, gen_binop_expr_no_assign env' expected_type + [ 3, gen_binop_expr_no_assign expected_type env' ; 2, gen_unop_expr_no_assign env' expected_type ; 2, gen_funcall env' expected_type ; 1, gen_id_expr_no_assign env expected_type @@ -258,7 +258,8 @@ and gen_id_expr env expected_type = gen_expr_no_assign env var_type >>= fun e -> return (EBinOp (OpAssign, EId id, e))) (* Binary operations *) -and gen_binop_expr env = function +and gen_binop_expr expected_type env = + match expected_type with | TypeBase TypeInt -> let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in let op_gen = Gen.oneof (List.map return int_ops) in @@ -408,7 +409,8 @@ and gen_unop_expr_no_assign env expected_type = | _ -> gen_expr_no_assign env expected_type (* Binary operations without assignment *) -and gen_binop_expr_no_assign env = function +and gen_binop_expr_no_assign expected_type env = + match expected_type with | TypeBase TypeInt -> let int_ops = [ OpAdd; OpSub; OpMul; OpDiv; OpMod ] in let op_gen = Gen.oneof (List.map return int_ops) in