diff --git a/.gitignore b/.gitignore index 1e2dbd8..bdbf52d 100644 --- a/.gitignore +++ b/.gitignore @@ -25,6 +25,7 @@ setup.log # Dune generated files *.install +*.opam # Local OPAM switch _opam/ diff --git a/bin/dune b/bin/dune index a4ef753..961c8b4 100644 --- a/bin/dune +++ b/bin/dune @@ -1,4 +1,28 @@ (executable - (public_name main) - (name main) - (libraries lang)) + (name main) + (public_name main) + (libraries exercises + miniImp + miniFun + utility) + (package miniFun) + (modes byte exe) +) + +(executable + (name miniFunInterpreter) + (public_name miniFunInterpreter) + (libraries miniFun + clap) + (package miniFun) + (modes byte exe) + ) + +(executable + (name miniImpInterpreter) + (public_name miniImpInterpreter) + (libraries miniImp + clap) + (package miniImp) + (modes byte exe) + ) \ No newline at end of file diff --git a/bin/fibonacci-fixed-point.minifun b/bin/fibonacci-fixed-point.minifun new file mode 100644 index 0000000..fccc7da --- /dev/null +++ b/bin/fibonacci-fixed-point.minifun @@ -0,0 +1,15 @@ +lambda n: int -> int => + +let fib = lambda f : (int -> int) -> int -> int => + \ n : int -> int => + if n == 0 then 0 + else if n == 1 then 1 + else f (n - 1) + f (n - 2) +in + +let rec fix f : ((int -> int) -> int -> int) -> int -> int = + \ x : int -> int => + f (fix f) x +in + +fix fib n diff --git a/bin/main.ml b/bin/main.ml index c6a0569..9d63d55 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1 +1,20 @@ -print_endline "Hello!" +open MiniImp +open MiniImp.Cfg + +let () = + let program = "def main with input x output y as + x := 2; + if y < 0 then ( + y := x + 3; + x := y; + ) else + x := 1 - y;" in + + + let get_result x = Lexing.from_string x |> Parser.prg Lexer.lex in + + let p = get_result program in + + let converted = convert p in + + Printf.printf "%a" Cfg.pp converted diff --git a/bin/miller-rabin.miniimp b/bin/miller-rabin.miniimp new file mode 100644 index 0000000..5727cb6 --- /dev/null +++ b/bin/miller-rabin.miniimp @@ -0,0 +1,25 @@ +def main with input n output result as + if (n % 2) == 0 then result := 1 + else ( + + result := 0; + s := 0; + while (0 == ((n - 1) / (2 ^ s)) % 2) do ( + s := s + 1 + ); + d := ((n - 1) / 2 ^ s); + for (i := 20, i > 0, i := i - 1) do ( + a := rand(n - 4) + 2; + x := powmod(a, d, n); + for (j := 0, j < s, j := j+1) do ( + y := powmod(x, 2, n); + if (y == 1 && (not x == 1) && (not x == n - 1)) then + result := 1; + else + skip; + x := y; + ); + if not y == 1 then result := 1; + else skip; + ) + ) diff --git a/bin/miniFunInterpreter.ml b/bin/miniFunInterpreter.ml new file mode 100644 index 0000000..43bea4b --- /dev/null +++ b/bin/miniFunInterpreter.ml @@ -0,0 +1,100 @@ +open MiniFun +open Lexing + +(* -------------------------------------------------------------------------- *) +(* Command Arguments *) + +let () = + Clap.description "Interpreter for MiniFun language."; + + let files = Clap.section ~description: "Files to consider." "FILES" in + let values = Clap.section ~description: "Input values." "VALUES" in + + let input = Clap.mandatory_string + ~description: "Input file." + ~placeholder: "FILENAME" + ~section: files + ~long: "input" + ~short: 'i' + () + in + + let inputval = Clap.optional_int + ~description: "Optional input value to feed to the program. \ + If not specified it is read from stdin." + ~placeholder: "INT" + ~section: values + ~long: "value" + ~short: 'v' + () + in + + let output = Clap.optional_string + ~description: "Output file. If not specified output is printed on stdout." + ~placeholder: "FILENAME" + ~section: files + ~long: "output" + ~long_synonyms: ["out"; "result"] + ~short: 'o' + () + in + + Clap.close (); + +(* -------------------------------------------------------------------------- *) +(* Interpreter *) + + let print_position outx lexbuf = + let pos = lexbuf.lex_curr_p in + Printf.fprintf outx "Encountered \"%s\" at %s:%d:%d" + (Lexing.lexeme lexbuf) pos.pos_fname + pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) + in + + let interpret_file inch (inval: int) outch = + let lexbuf = Lexing.from_channel inch in + let program = + try Parser.prg Lexer.read lexbuf with + | Lexer.LexingError msg -> + Printf.fprintf stderr "%a: %s\n" print_position lexbuf msg; + exit (-1) + | Parser.Error -> Printf.fprintf stderr "%a: syntax error\n" print_position lexbuf; + exit (-1) + in + let _ = + match TypeChecker.typecheck program with + | Ok _ -> () + | Error (`AbsentAssignment msg) + | Error (`WrongTypeSpecification msg) + | Error (`WrongType msg) -> + Printf.fprintf stderr "%s\n" msg; + exit (-1) + in + let return_value = + match Semantics.reduce program inval with + Ok o -> o + | Error (`AbsentAssignment msg) + | Error (`DivisionByZero msg) + | Error (`WrongType msg) -> + Printf.fprintf stderr "%s\n" msg; + exit (-1) + in + + Printf.fprintf outch "%d\n" return_value + in + + + let inx = In_channel.open_text input in + let outx = match output with + None -> stdout + | Some f -> Out_channel.open_text f + in + + let inputval = match inputval with + None -> ( + Printf.fprintf stdout "Provide the input: "; + read_int () + ) + | Some o -> o + in + interpret_file inx inputval outx; diff --git a/bin/miniImpInterpreter.ml b/bin/miniImpInterpreter.ml new file mode 100644 index 0000000..999c858 --- /dev/null +++ b/bin/miniImpInterpreter.ml @@ -0,0 +1,91 @@ +open MiniImp +open Lexing + +(* -------------------------------------------------------------------------- *) +(* Command Arguments *) + +let () = + Clap.description "Interpreter for MiniImp language."; + + let files = Clap.section ~description: "Files to consider." "FILES" in + let values = Clap.section ~description: "Input values." "VALUES" in + + let input = Clap.mandatory_string + ~description: "Input file." + ~placeholder: "FILENAME" + ~section: files + ~long: "input" + ~short: 'i' + () + in + + let inputval = Clap.optional_int + ~description: "Optional input value to feed to the program. \ + If not specified it is read from stdin." + ~placeholder: "INT" + ~section: values + ~long: "value" + ~short: 'v' + () + in + + let output = Clap.optional_string + ~description: "Output file. If not specified output is printed on stdout." + ~placeholder: "FILENAME" + ~section: files + ~long: "output" + ~long_synonyms: ["out"; "result"] + ~short: 'o' + () + in + + Clap.close (); + +(* -------------------------------------------------------------------------- *) +(* Interpreter *) + + let print_position outx lexbuf = + let pos = lexbuf.lex_curr_p in + Printf.fprintf outx "Encountered \"%s\" at %s:%d:%d" + (Lexing.lexeme lexbuf) pos.pos_fname + pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) + in + + let interpret_file inch (inval: int) outch = + let lexbuf = Lexing.from_channel inch in + let program = + try Parser.prg Lexer.read lexbuf with + | Lexer.LexingError msg -> + Printf.fprintf stderr "%a: %s\n" print_position lexbuf msg; + exit (-1) + | Parser.Error -> Printf.fprintf stderr "%a: syntax error\n" print_position lexbuf; + exit (-1) + in + let return_value = + match Semantics.reduce program inval with + Ok o -> o + | Error (`AbsentAssignment msg) + | Error (`DivisionByZero msg) + | Error (`WrongType msg) -> + Printf.fprintf stderr "%s\n" msg; + exit (-1) + in + + Printf.fprintf outch "%d\n" return_value + in + + + let inx = In_channel.open_text input in + let outx = match output with + None -> stdout + | Some f -> Out_channel.open_text f + in + + let inputval = match inputval with + None -> ( + Printf.fprintf stdout "Provide the input: "; + read_int () + ) + | Some o -> o + in + interpret_file inx inputval outx; diff --git a/bin/sum.miniimp b/bin/sum.miniimp new file mode 100644 index 0000000..ec74aed --- /dev/null +++ b/bin/sum.miniimp @@ -0,0 +1,8 @@ +def main with input in output out as + x := in; + out := 0; + while not x < 0 do ( + out := out + x; + x := x - 1; + ); + skip diff --git a/dune-project b/dune-project index c16cb8e..900aba8 100644 --- a/dune-project +++ b/dune-project @@ -4,6 +4,20 @@ (generate_opam_files true) +(using menhir 3.0) + (package - (name lang) + (name utility) + (depends ocaml dune)) + +(package + (name miniImp) + (depends ocaml dune utility)) + +(package + (name miniFun) + (depends ocaml dune utility)) + +(package + (name exercises) (depends ocaml dune)) diff --git a/lang.opam b/lang.opam deleted file mode 100644 index 75de6b8..0000000 --- a/lang.opam +++ /dev/null @@ -1,21 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -depends: [ - "ocaml" - "dune" {>= "3.16"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] diff --git a/lib/dune b/lib/dune deleted file mode 100644 index 7690322..0000000 --- a/lib/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name lang) - (public_name lang)) - -(include_subdirs qualified) \ No newline at end of file diff --git a/lib/exercises/dune b/lib/exercises/dune new file mode 100644 index 0000000..280c335 --- /dev/null +++ b/lib/exercises/dune @@ -0,0 +1,5 @@ +(library + (name exercises) + (public_name exercises)) + +(include_subdirs qualified) \ No newline at end of file diff --git a/lib/exercises.ml b/lib/exercises/exercises.ml similarity index 93% rename from lib/exercises.ml rename to lib/exercises/exercises.ml index efc8adc..895bde5 100644 --- a/lib/exercises.ml +++ b/lib/exercises/exercises.ml @@ -34,10 +34,10 @@ type 'a my_tree = let mod_list y = (List.fold_left (fun acc x -> - match acc with - | [a] when ((List.hd a) = x) -> [x :: a] - | a :: tl when ((List.hd a) = x) -> (x :: a) :: tl - | _ -> [x] :: acc) + match acc with + | [a] when ((List.hd a) = x) -> [x :: a] + | a :: tl when ((List.hd a) = x) -> (x :: a) :: tl + | _ -> [x] :: acc) [] y) |> List.rev @@ -46,7 +46,7 @@ let mod_list y = let to_tup f g = fun x -> match x with - (a, b) -> (f a, g b) + (a, b) -> (f a, g b) let partialsum l = snd (List.fold_left_map (fun acc x -> (acc+x, acc+x)) 0 l) diff --git a/lib/exercises.mli b/lib/exercises/exercises.mli similarity index 100% rename from lib/exercises.mli rename to lib/exercises/exercises.mli diff --git a/lib/lang.ml b/lib/lang.ml deleted file mode 100644 index 3ddfe33..0000000 --- a/lib/lang.ml +++ /dev/null @@ -1,13 +0,0 @@ -module Exercises = Exercises - -(* -------------------------------- MINI IMP -------------------------------- *) -module MiniImpTypes = MiniImp.Types - -module MiniImp = MiniImp.Semantics - -(* -------------------------------- MINI FUN -------------------------------- *) -module MiniFunTypes = MiniFun.Types - -module MiniTyFun = MiniFun.TypeChecker - -module MiniFun = MiniFun.Semantics diff --git a/lib/miniFun/Lexer.mll b/lib/miniFun/Lexer.mll new file mode 100644 index 0000000..f9ebd40 --- /dev/null +++ b/lib/miniFun/Lexer.mll @@ -0,0 +1,95 @@ +{ + open Parser + exception LexingError of string + + let create_hashtable size init = + let tbl = Hashtbl.create size in + List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + + let keyword_table = + let mapping = [ + ("bool", TYPEBOOL); + ("else", ELSE); + ("false", BOOL(false)); + ("fst", FIRST); + ("snd", SECOND); + ("fun", LAMBDA); + ("if", IF); + ("in", IN); + ("int", TYPEINT); + ("lambda", LAMBDA); + ("let", LET); + ("not", BNOT); + ("powmod", POWERMOD); + ("rand", RAND); + ("rec", REC); + ("then", THEN); + ("true", BOOL(true)); + ] + in create_hashtable (List.length mapping) mapping +} + + +let digit = ['0'-'9'] +let alpha = ['a'-'z' 'A'-'Z'] +let white = [' ' '\t']+ | '\r' | '\n' | "\r\n" + +let integer = ('-')?(digit)(digit*) +let var = (alpha|'_') (alpha|digit|'_')* + +let symbols = ['!'-'/' ':'-'?' '[' ']' '^' '{'-'}' '~'] + +(* lexing rules *) +rule read = parse + | white {read lexbuf} + | var as v { + match Hashtbl.find_opt keyword_table v with + | Some keyword -> keyword + | None -> VARIABLE(v) + } + | "%" {MODULO} + | "&&" {BAND} + | "(" {LEFTPAR} + | ")" {RIGHTPAR} + | "*" {TIMES} + | "+" {PLUS} + | "," {COMMA} + | "-" {MINUS} + | "->" {TYPEFUNCTION} + | "/" {DIVISION} + | ":" {COLUMN} + | "<" {CMPLESS} + | "<=" {CMPLESSEQ} + | "=" {ASSIGNMENT} + | "==" {CMP} + | "=>" {RESULTS} + | ">" {CMPGREATER} + | ">=" {CMPGREATEREQ} + | "\\" {LAMBDA} + | "^" {POWER} + | "||" {BOR} + | integer as i {INT(int_of_string i)} + | "(*" {comments 0 lexbuf} + | eof {EOF} + | _ { + raise + (LexingError + (Printf.sprintf + "Error scanning %s on line %d at char %d" + (Lexing.lexeme lexbuf) + (lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum) + (lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum) + ))} +and comments level = parse + | "*)" {if level = 0 + then read lexbuf + else comments (level-1) lexbuf} + | "(*" {comments (level+1) lexbuf} + | _ {comments level lexbuf} + | eof {raise (LexingError ("Comment is not closed"))} + + +{ + let lex = read +} diff --git a/lib/miniFun/Parser.mly b/lib/miniFun/Parser.mly new file mode 100644 index 0000000..bfdec51 --- /dev/null +++ b/lib/miniFun/Parser.mly @@ -0,0 +1,98 @@ +(* code to be copied in the scanner module *) +(* +*) +%{ + open Types +%} + +(* tokens *) +%token TYPEBOOL TYPEINT TYPEFUNCTION +%token LAMBDA RAND IF IN THEN ELSE LET REC BNOT POWERMOD RESULTS +%token BOOL +%token VARIABLE +%token INT +%token COMMA COLUMN LEFTPAR RIGHTPAR CMPLESS CMPGREATER PLUS MINUS TIMES +%token DIVISION MODULO POWER ASSIGNMENT BAND BOR CMP CMPLESSEQ CMPGREATEREQ +%token FIRST SECOND +%token EOF + +%type prg +%type texp +%type typeexp + +(* start nonterminal *) +%start prg + +(* associativity in order of precedence *) +/*%right rightlowest */ +%left lowest +%right TYPEFUNCTION +%left COMMA +%nonassoc INT BOOL VARIABLE +%left POWERMOD +%left IF +%left BOR BAND +%left CMP CMPLESS CMPLESSEQ CMPGREATER CMPGREATEREQ +%left PLUS MINUS +%left TIMES DIVISION MODULO +%left POWER +%right BNOT RAND +%left FIRST SECOND +%left LAMBDA +%left LET +%left LEFTPAR +%right righthighest + +%% + +(* grammar *) +prg: + | e = texp; EOF {e} +texp: + | i = INT {Integer (i)} + | b = BOOL {Boolean (b)} + | a = VARIABLE {Variable (a)} + | LEFTPAR; a = texp; COMMA; b = texp; RIGHTPAR + {Tuple (a, b)} + | LAMBDA; v = VARIABLE; COLUMN; t = typeexp; RESULTS; body = texp + %prec lowest {Function (v, t, body)} + | a = texp; b = texp {Application (a, b)} %prec righthighest + | a = texp; PLUS; b = texp {Plus (a, b)} + | a = texp; MINUS; b = texp {Minus (a, b)} + | a = texp; TIMES; b = texp {Times (a, b)} + | a = texp; DIVISION; b = texp {Division (a, b)} + | a = texp; MODULO; b = texp {Modulo (a, b)} + | a = texp; POWER; b = texp {Power (a, b)} + | a = texp; BAND; b = texp {BAnd (a, b)} + | a = texp; BOR; b = texp {BOr (a, b)} + + | FIRST; a = texp {First (a)} + | SECOND; a = texp {Second (a)} + + | a = texp; CMP; b = texp {Cmp (a, b)} + | a = texp; CMPLESS; b = texp {CmpLess (a, b)} + | a = texp; CMPLESSEQ; b = texp {CmpLessEq (a, b)} + | a = texp; CMPGREATER; b = texp {CmpGreater (a, b)} + | a = texp; CMPGREATEREQ; b = texp {CmpGreaterEq (a, b)} + + | POWERMOD; LEFTPAR; t1 = texp; COMMA; + t2 = texp; COMMA; + t3 = texp; RIGHTPAR + {PowerMod (t1, t2, t3)} + | RAND; t = texp; {Rand (t)} + | BNOT; b = texp {BNot (b)} + | IF; b = texp; THEN; c1 = texp; ELSE; c2 = texp; + %prec lowest {IfThenElse (b, c1, c2)} + | LET; v = VARIABLE; ASSIGNMENT; c = texp; IN; rest = texp + %prec lowest {LetIn (v, c, rest)} + | LET; REC; f = VARIABLE; x = VARIABLE; COLUMN; t = typeexp; ASSIGNMENT; body = texp; IN; rest = texp + %prec lowest {LetFun (f, x, t, body, rest)} + | LEFTPAR; a = texp; RIGHTPAR {a} +typeexp: + | TYPEINT {IntegerType} + | TYPEBOOL {BooleanType} + | v = delimited(LEFTPAR, typeexp, RIGHTPAR) + {v} + | a = typeexp; COMMA; b = typeexp {TupleType (a, b)} + | vin = typeexp; TYPEFUNCTION; vout = typeexp + {FunctionType (vin, vout)} diff --git a/lib/miniFun/Semantics.ml b/lib/miniFun/Semantics.ml index 1c4ac73..49640d6 100644 --- a/lib/miniFun/Semantics.ml +++ b/lib/miniFun/Semantics.ml @@ -5,7 +5,7 @@ Random.self_init () let (let*) = Result.bind -let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) result = +let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, [> error]) result = match command with Integer n -> Ok (IntegerPermitted n) | Boolean b -> Ok (BooleanPermitted b) @@ -14,14 +14,19 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul None -> Error (`AbsentAssignment ("The variable " ^ v ^ " is not defined.")) | Some a -> Ok a ) - | Function (xs, _, f) -> + | Tuple (x, y) -> ( + let* xval = evaluate mem x in + let* yval = evaluate mem y in + Ok (TuplePermitted (xval, yval)) + ) + | Function (x, _, f) -> Ok (FunctionPermitted - {inputList = xs; + {input = x; body = f; assignments = mem.assignments; recursiveness = None} ) - | Application (f, xs) -> ( + | Application (f, x) -> ( let* evalf = evaluate mem f in let* funcClosure = ( match evalf with @@ -30,45 +35,20 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul ^ " it's an integer")) | BooleanPermitted _ -> Error (`WrongType ("Function is not a function," ^ " it's a boolean")) + | TuplePermitted _ -> Error (`WrongType ("Function is not a function," + ^ " it's a tuple")) ) in - let parmList = List.map (fun k -> evaluate mem k) xs in - let rec helper m params values = - match (params, values) with - (_, []) -> Ok (m, params) - | ([], _) -> - Error (`WrongArity ("Function application has arity " ^ - (List.length funcClosure.inputList - |> string_of_int) ^ - ", but was applied to " ^ - (List.length xs |> string_of_int) ^ - " parameters")) - | (p::tlparams, (Ok v)::tlvalues) -> helper - (VariableMap.add p v m) - tlparams - tlvalues - | (_, (Error e)::_) -> Error e - in - let* (mem2assignments, params) = helper - funcClosure.assignments - funcClosure.inputList - parmList - in - let mem2 = ( + let* param = evaluate mem x in + let mem2 = match funcClosure.recursiveness with - None -> {assignments = mem2assignments} - | Some nameF -> { - assignments = - VariableMap.add - nameF - (FunctionPermitted funcClosure) - mem2assignments - } - ) in - match params with - [] -> evaluate mem2 funcClosure.body - | _ -> ( - Ok (FunctionPermitted {funcClosure with inputList = params; - assignments = mem2assignments})) + None -> {assignments = ( + VariableMap.add funcClosure.input param funcClosure.assignments)} + | Some nameF -> {assignments = ( + VariableMap.add funcClosure.input param funcClosure.assignments |> + VariableMap.add nameF (FunctionPermitted funcClosure) + )} + in + evaluate mem2 funcClosure.body ) | Plus (a, b) -> let* aval = ( @@ -248,7 +228,24 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul ) in Ok (BooleanPermitted (not aval)) - + | First a -> + let* aval = ( + match evaluate mem a with + Ok TuplePermitted (x, _) -> Ok x + | Error e -> Error e + | _ -> Error (`WrongType ("Value is not a tuple")) + ) + in + Ok (aval) + | Second a -> + let* aval = ( + match evaluate mem a with + Ok TuplePermitted (_, x) -> Ok x + | Error e -> Error e + | _ -> Error (`WrongType ("Value is not a tuple")) + ) + in + Ok (aval) | Cmp (exp_1, exp_2) -> let* exp_1val = match evaluate mem exp_1 with Ok IntegerPermitted x -> Ok x @@ -329,13 +326,13 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul let* evalxval = evaluate mem xval in let mem2 = {assignments = VariableMap.add x evalxval mem.assignments} in evaluate mem2 rest - | LetFun (f, xs, _, fbody, rest) -> + | LetFun (f, x, _, fbody, rest) -> let mem2 = { assignments = VariableMap.add f (FunctionPermitted - { inputList = xs; + { input = x; body = fbody; assignments = mem.assignments; recursiveness = Some f}) @@ -344,8 +341,8 @@ let rec evaluate (mem: memory) (command: t_exp) : (permittedValues, error) resul evaluate mem2 rest -let reduce (program: t_exp) (iin : int) : (int, error) result = - let program' = (Application (program, [(Integer iin)])) in +let reduce (program: t_exp) (iin : int) : (int, [> error]) result = + let program' = (Application (program, (Integer iin))) in let mem : memory = {assignments = VariableMap.empty} in match (evaluate mem program') with Ok IntegerPermitted a -> Ok a diff --git a/lib/miniFun/Semantics.mli b/lib/miniFun/Semantics.mli index 9907835..176883e 100644 --- a/lib/miniFun/Semantics.mli +++ b/lib/miniFun/Semantics.mli @@ -1 +1,3 @@ -val reduce : Types.t_exp -> int -> (int, Types.error) result +val evaluate : Types.memory -> Types.t_exp -> (Types.permittedValues, [> Types.error]) result + +val reduce : Types.t_exp -> int -> (int, [> Types.error]) result diff --git a/lib/miniFun/TypeChecker.ml b/lib/miniFun/TypeChecker.ml index 2498200..fc8e17f 100644 --- a/lib/miniFun/TypeChecker.ml +++ b/lib/miniFun/TypeChecker.ml @@ -5,11 +5,10 @@ Random.self_init () let (let*) = Result.bind - let rec principalTypings (D: ) (e: t_exp) : () result -let evaluate_type (_program: t_exp) (_context: typingshape) : (typingshape, error) result = - failwith "asd" +let evaluate_type_polimorphic (_program: t_exp) (_context: typingshape) : (typingshape, error) result = + failwith "Not implemented" (* match program with *) (* Integer _ -> Ok (VariableMap.empty, IntegerType) *) (* | Boolean _ -> Ok (VariableMap.empty, BooleanType) *) @@ -56,5 +55,155 @@ let evaluate_type (_program: t_exp) (_context: typingshape) : (typingshape, erro (* | LetIn (x, xval, rest) -> failwith "Not Implemented" *) (* | LetFun (f, xs, typef, fbody, rest) -> failwith "Not Implemented" *) -let typecheck (_program: t_exp) : (ftype, error) result = - failwith "Not Implemented" +let rec evaluate_type (program: t_exp) (context: ftype VariableMap.t) : (ftype, [> typechecking_error]) result = + match program with + Integer _ -> Ok IntegerType + | Boolean _ -> Ok BooleanType + | Variable x -> ( (* check for the type in the context *) + match VariableMap.find_opt x context with + None -> Error (`AbsentAssignment + ("The variable " ^ x ^ " is not defined.")) + | Some t -> Ok t + ) + | Tuple (x, y) -> ( + let* xtype = evaluate_type x context in + let* ytype = evaluate_type y context in + Ok (TupleType (xtype, ytype)) + ) + | Function (x, typef, fbody) -> ( + (* first check that the function has the right specified type then check + the type of the body using the bindings for the input *) + match typef with + FunctionType (tin, tout) -> ( + let* typefbody = evaluate_type fbody (VariableMap.add x tin context) in + if (typefbody = tout) then + Ok typef + else + Error (`WrongTypeSpecification + ("Function does not return specified type.")) + ) + | _ -> Error (`WrongTypeSpecification + ("Specification of function is not a function type.")) + ) + | Application (f, x) -> ( + let* evalf = evaluate_type f context in + let* evalx = evaluate_type x context in + match evalf with + FunctionType (tin, tout) -> ( + if tin = evalx then + Ok tout + else + Error (`WrongType "Appling function with wrong input type to value") + ) + | _ -> Error (`WrongType "Applying to a non function type") + ) + | Plus (x, y) + | Minus (x, y) + | Times (x, y) + | Division (x, y) + | Modulo (x, y) + | Power (x, y) -> ( + let* typex = evaluate_type x context in + let* typey = evaluate_type y context in + match typex, typey with + | (IntegerType, IntegerType) -> Ok IntegerType + | (IntegerType, _) -> Error (`WrongType "Second term is not an integer.") + | (_, _) -> Error (`WrongType "First term is not an integer.") + ) + | PowerMod (x, y, z) -> ( + let* typex = evaluate_type x context in + let* typey = evaluate_type y context in + let* typez = evaluate_type z context in + match typex, typey, typez with + | (IntegerType, IntegerType, IntegerType) -> Ok IntegerType + | (IntegerType, IntegerType, _) -> Error (`WrongType ("Third term is " ^ + "not an integer.")) + | (IntegerType, _, _) -> Error (`WrongType + ("Second term is not an integer.")) + | (_, _, _) -> Error (`WrongType "First term is not an integer.") + ) + | Rand (x) -> ( + let* typex = evaluate_type x context in + match typex with + | (IntegerType) -> Ok IntegerType + | (_) -> Error (`WrongType "Term is not an integer.") + ) + | BAnd (x, y) + | BOr (x, y) -> ( + let* typex = evaluate_type x context in + let* typey = evaluate_type y context in + match typex, typey with + | (BooleanType, BooleanType) -> Ok BooleanType + | (BooleanType, _) -> Error (`WrongType "Second term is not a boolean.") + | (_, _) -> Error (`WrongType "First term is not a boolean.") + ) + | BNot (x) -> ( + let* typex = evaluate_type x context in + match typex with + | (BooleanType) -> Ok BooleanType + | (_) -> Error (`WrongType "Term is not a boolean.") + ) + | First (x) -> ( + let* typex = evaluate_type x context in + match typex with + | (TupleType (x, _)) -> Ok x + | (_) -> Error (`WrongType "Term is not a tuple.") + ) + | Second (x) -> ( + let* typex = evaluate_type x context in + match typex with + | (TupleType (_, x)) -> Ok x + | (_) -> Error (`WrongType "Term is not a tuple.") + ) + | Cmp (x, y) + | CmpLess (x, y) + | CmpLessEq (x, y) + | CmpGreater (x, y) + | CmpGreaterEq (x, y) -> ( + let* typex = evaluate_type x context in + let* typey = evaluate_type y context in + match typex, typey with + | (IntegerType, IntegerType) -> Ok BooleanType + | (IntegerType, _) -> Error (`WrongType "Second term is not an integer.") + | (_, _) -> Error (`WrongType "First term is not an integer.") + ) + | IfThenElse (guard, if_exp, else_exp) -> ( + let* typeguard = evaluate_type guard context in + let* typeif_exp = evaluate_type if_exp context in + let* typeelse_exp = evaluate_type else_exp context in + match typeguard, typeif_exp, typeelse_exp with + (BooleanType, t1, t2) -> ( + if t1 = t2 then + Ok t1 + else + Error (`WrongType "If branches do not have the same type.") + ) + | (_, _, _) -> Error (`WrongType "If guard is not a boolean.") + ) + | LetIn (x, xval, rest) -> + (* bind the type to the variable name in the context *) + let* typex = evaluate_type xval context in + evaluate_type rest (VariableMap.add x typex context) + | LetFun (f, x, typef, fbody, rest) -> + (* like with the function case, but also add f itself to the bindings *) + match typef with + FunctionType (tin, tout) -> ( + let newcontext = VariableMap.add f typef context in + let newcontextwithx = VariableMap.add x tin newcontext in + let* typefbody = evaluate_type fbody newcontextwithx in + let* typerest = evaluate_type rest newcontext in + match (typefbody = tout, typerest) with + (false, _) -> Error (`WrongTypeSpecification + "Function does not return specified type.") + | (true, t) -> Ok t + ) + | _ -> Error (`WrongTypeSpecification + "Specification of function is not a function type.") + +let typecheck (program: t_exp) : (ftype, [> typechecking_error]) result = + let* typeprogram = evaluate_type program VariableMap.empty in + match typeprogram with + FunctionType (IntegerType, IntegerType) -> ( + Ok (typeprogram) + ) + | _ -> Error (`WrongType "Program is not a function from int to int.") diff --git a/lib/miniFun/TypeChecker.mli b/lib/miniFun/TypeChecker.mli index 286691a..bb296d2 100644 --- a/lib/miniFun/TypeChecker.mli +++ b/lib/miniFun/TypeChecker.mli @@ -1 +1 @@ -val typecheck : Types.t_exp -> (Types.ftype, Types.error) result +val typecheck : Types.t_exp -> (Types.ftype, [> Types.typechecking_error]) result diff --git a/lib/miniFun/Types.ml b/lib/miniFun/Types.ml index bf685a5..a8ae12f 100644 --- a/lib/miniFun/Types.ml +++ b/lib/miniFun/Types.ml @@ -8,8 +8,9 @@ module VariableSet = Set.Make(String) type ftype = IntegerType | BooleanType + | TupleType of ftype * ftype | PolimorphicType of string - | FunctionType of ftype list * ftype + | FunctionType of ftype * ftype type fsubstitution = (* goes from polimorphic types to types *) ftype VariableMap.t type fenvironment = (* goes from variables to types *) @@ -21,8 +22,9 @@ type t_exp = Integer of int (* x := a *) | Boolean of bool (* v *) | Variable of variable (* x *) - | Function of variable list * ftype * t_exp (* lambda x: t. x *) - | Application of t_exp * t_exp list (* x x *) + | Tuple of t_exp * t_exp (* (a, b) *) + | Function of variable * ftype * t_exp (* lambda x: t. x *) + | Application of t_exp * t_exp (* x x *) | Plus of t_exp * t_exp (* x + x *) | Minus of t_exp * t_exp (* x - x *) | Times of t_exp * t_exp (* x * x *) @@ -31,9 +33,11 @@ type t_exp = | Power of t_exp * t_exp (* x ^ x *) | PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *) | Rand of t_exp (* rand(0, x) *) - | BAnd of t_exp * t_exp (* x and x *) - | BOr of t_exp * t_exp (* x or x *) + | BAnd of t_exp * t_exp (* x && x *) + | BOr of t_exp * t_exp (* x || x *) | BNot of t_exp (* not x *) + | First of t_exp (* fst x *) + | Second of t_exp (* scn x *) | Cmp of t_exp * t_exp (* x == x *) | CmpLess of t_exp * t_exp (* x < x *) | CmpLessEq of t_exp * t_exp (* x <= x *) @@ -41,14 +45,15 @@ type t_exp = | CmpGreaterEq of t_exp * t_exp (* x >= x *) | IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *) | LetIn of variable * t_exp * t_exp (* let x = x in x *) - | LetFun of variable * variable list * ftype * t_exp * t_exp (* let rec x: t. x in x *) + | LetFun of variable * variable * ftype * t_exp * t_exp (* let rec x. y: t. x in x*) type permittedValues = - IntegerPermitted of int - | BooleanPermitted of bool + IntegerPermitted of int + | BooleanPermitted of bool + | TuplePermitted of permittedValues * permittedValues | FunctionPermitted of closure and closure = { - inputList: variable list; + input: variable; body: t_exp; assignments: permittedValues VariableMap.t; recursiveness: variable option @@ -58,10 +63,18 @@ type memory = { assignments: permittedValues VariableMap.t } -type error = [ + +type base_error = [ `AbsentAssignment of string | `WrongType of string - | `DivisionByZero of string - | `WrongArity of string +] + +type typechecking_error = [ + | base_error | `WrongTypeSpecification of string ] + +type error = [ + | base_error + | `DivisionByZero of string +] diff --git a/lib/miniFun/Types.mli b/lib/miniFun/Types.mli index 59262cd..543b439 100644 --- a/lib/miniFun/Types.mli +++ b/lib/miniFun/Types.mli @@ -8,8 +8,9 @@ module VariableSet : Set.S with type elt = string type ftype = IntegerType | BooleanType + | TupleType of ftype * ftype | PolimorphicType of variable - | FunctionType of ftype list * ftype + | FunctionType of ftype * ftype type fsubstitution = (* goes from polimorphic types to types *) ftype VariableMap.t type fenvironment = (* goes from variables to types *) @@ -47,8 +48,9 @@ type t_exp = Integer of int (* x := a *) | Boolean of bool (* v *) | Variable of variable (* x *) - | Function of variable list * ftype * t_exp (* lambda x: t. x *) - | Application of t_exp * t_exp list (* x x *) + | Tuple of t_exp * t_exp (* (a, b) *) + | Function of variable * ftype * t_exp (* lambda x: t. x *) + | Application of t_exp * t_exp (* x x *) | Plus of t_exp * t_exp (* x + x *) | Minus of t_exp * t_exp (* x - x *) | Times of t_exp * t_exp (* x * x *) @@ -57,9 +59,11 @@ type t_exp = | Power of t_exp * t_exp (* x ^ x *) | PowerMod of t_exp * t_exp * t_exp (* (x ^ x) % x *) | Rand of t_exp (* rand(0, x) *) - | BAnd of t_exp * t_exp (* x and x *) - | BOr of t_exp * t_exp (* x or x *) + | BAnd of t_exp * t_exp (* x && x *) + | BOr of t_exp * t_exp (* x || x *) | BNot of t_exp (* not x *) + | First of t_exp (* fst x *) + | Second of t_exp (* scn x *) | Cmp of t_exp * t_exp (* x == x *) | CmpLess of t_exp * t_exp (* x < x *) | CmpLessEq of t_exp * t_exp (* x <= x *) @@ -67,14 +71,15 @@ type t_exp = | CmpGreaterEq of t_exp * t_exp (* x >= x *) | IfThenElse of t_exp * t_exp * t_exp (* if b then c else c *) | LetIn of variable * t_exp * t_exp (* let x = x in x *) - | LetFun of variable * variable list * ftype * t_exp * t_exp (* let rec x: t. x in x *) + | LetFun of variable * variable * ftype * t_exp * t_exp (* let rec x. y: t. x in x*) type permittedValues = - IntegerPermitted of int - | BooleanPermitted of bool + IntegerPermitted of int + | BooleanPermitted of bool + | TuplePermitted of permittedValues * permittedValues | FunctionPermitted of closure and closure = { - inputList: variable list; + input: variable; body: t_exp; assignments: permittedValues VariableMap.t; recursiveness: variable option @@ -84,10 +89,18 @@ type memory = { assignments: permittedValues VariableMap.t } -type error = [ + +type base_error = [ `AbsentAssignment of string | `WrongType of string - | `DivisionByZero of string - | `WrongArity of string +] + +type typechecking_error = [ + | base_error | `WrongTypeSpecification of string ] + +type error = [ + | base_error + | `DivisionByZero of string +] diff --git a/lib/miniFun/dune b/lib/miniFun/dune new file mode 100644 index 0000000..3547f71 --- /dev/null +++ b/lib/miniFun/dune @@ -0,0 +1,16 @@ +(ocamllex Lexer) + +(menhir + (modules Parser) + (explain true) + (infer true) + (flags --dump --table) + ) + +(library + (name miniFun) + (public_name miniFun) + (modules Lexer Parser Types Semantics TypeChecker) + (libraries utility menhirLib)) + +(include_subdirs qualified) diff --git a/lib/miniImp/Cfg.ml b/lib/miniImp/Cfg.ml new file mode 100644 index 0000000..7e92de6 --- /dev/null +++ b/lib/miniImp/Cfg.ml @@ -0,0 +1,316 @@ +type simpleStatements = + | SimpleSkip + | SimpleAssignment of Types.variable * simpleArithmetic + | SimpleGuard of simpleBoolean +and simpleBoolean = + | SimpleBoolean of bool + | SimpleBAnd of simpleBoolean * simpleBoolean + | SimpleBOr of simpleBoolean * simpleBoolean + | SimpleBNot of simpleBoolean + | SimpleBCmp of simpleArithmetic * simpleArithmetic + | SimpleBCmpLess of simpleArithmetic * simpleArithmetic + | SimpleBCmpLessEq of simpleArithmetic * simpleArithmetic + | SimpleBCmpGreater of simpleArithmetic * simpleArithmetic + | SimpleBCmpGreaterEq of simpleArithmetic * simpleArithmetic +and simpleArithmetic = + | SimpleVariable of Types.variable + | SimpleInteger of int + | SimplePlus of simpleArithmetic * simpleArithmetic + | SimpleMinus of simpleArithmetic * simpleArithmetic + | SimpleTimes of simpleArithmetic * simpleArithmetic + | SimpleDivision of simpleArithmetic * simpleArithmetic + | SimpleModulo of simpleArithmetic * simpleArithmetic + | SimplePower of simpleArithmetic * simpleArithmetic + | SimplePowerMod of simpleArithmetic * simpleArithmetic * simpleArithmetic + | SimpleRand of simpleArithmetic + +let printSingleStatement (ppf) (c: simpleStatements) : unit = + let rec helper_c (ppf) (c: simpleStatements) : unit = + match c with + | SimpleSkip -> Printf.fprintf ppf "Skip" + | SimpleAssignment (v, a) -> Printf.fprintf ppf "Assignment {%s, %a}" v helper_a a + | SimpleGuard (b) -> Printf.fprintf ppf "Guard {%a}" helper_b b + and helper_b (ppf) (c: simpleBoolean) : unit = + match c with + | SimpleBoolean b -> Printf.fprintf ppf "%b" b + | SimpleBAnd (b1, b2) -> Printf.fprintf ppf "{%a && %a}" helper_b b1 helper_b b2 + | SimpleBOr (b1, b2) -> Printf.fprintf ppf "{%a || %a}" helper_b b1 helper_b b2 + | SimpleBNot b -> Printf.fprintf ppf "{not %a}" helper_b b + | SimpleBCmp (a1, a2) -> Printf.fprintf ppf "{%a == %a}" helper_a a1 helper_a a2 + | SimpleBCmpLess (a1, a2) -> Printf.fprintf ppf "{%a < %a}" helper_a a1 helper_a a2 + | SimpleBCmpLessEq (a1, a2) -> Printf.fprintf ppf "{%a <= %a}" helper_a a1 helper_a a2 + | SimpleBCmpGreater (a1, a2) -> Printf.fprintf ppf "{%a > %a}" helper_a a1 helper_a a2 + | SimpleBCmpGreaterEq (a1, a2) -> Printf.fprintf ppf "{%a >= %a}" helper_a a1 helper_a a2 + and helper_a (ppf) (c: simpleArithmetic) : unit = + match c with + | SimpleVariable (v) -> Printf.fprintf ppf "%s" v + | SimpleInteger (i) -> Printf.fprintf ppf "%d" i + | SimplePlus (a1, a2) -> Printf.fprintf ppf "{%a + %a}" helper_a a1 helper_a a2 + | SimpleMinus (a1, a2) -> Printf.fprintf ppf "{%a - %a}" helper_a a1 helper_a a2 + | SimpleTimes (a1, a2) -> Printf.fprintf ppf "{%a * %a}" helper_a a1 helper_a a2 + | SimpleDivision (a1, a2) -> Printf.fprintf ppf "{%a / %a}" helper_a a1 helper_a a2 + | SimpleModulo (a1, a2) -> Printf.fprintf ppf "{%a %% %a}" helper_a a1 helper_a a2 + | SimplePower (a1, a2) -> Printf.fprintf ppf "{%a ^ %a}" helper_a a1 helper_a a2 + | SimplePowerMod (a1, a2, a3) -> Printf.fprintf ppf "{powmod %a %a %a}" helper_a a1 helper_a a2 helper_a a3 + | SimpleRand (a) -> Printf.fprintf ppf "{rand %a}" helper_a a + in + helper_c ppf c + +let printSimpleStatements (ppf) (c: simpleStatements list) : unit = + List.iter (fun x -> printSingleStatement ppf x; Printf.printf "; ") c + + + +let globalIdNode = ref 0; + +module Node = struct + type t = { + id: int + } + let compare a b = compare a.id b.id + + let newNode () = + globalIdNode := !globalIdNode + 1; + {id = !globalIdNode} +end +;; + +module NodeMap = Map.Make(Node) +module NodeSet = Set.Make(Node) + +module Cfg = struct + type t = { + empty: bool; + nodes: NodeSet.t; + edges: (Node.t * (Node.t option)) NodeMap.t; + reverseedges: (Node.t list) NodeMap.t; + initial: Node.t option; + terminal: Node.t option; + code: (simpleStatements list) NodeMap.t + } + + let newCfg () = + { empty = true; + nodes = NodeSet.empty; + edges = NodeMap.empty; + reverseedges = NodeMap.empty; + initial = None; + terminal = None; + code = NodeMap.empty } + + let mergeCfg (cfg1: t) (cfg2: t) (entryNode: Node.t) (exitNode: Node.t) : t = + match (cfg1.empty, cfg2.empty) with + true, _ -> cfg2 + | _, true -> cfg1 + | false, false -> + let cfg1initial = Option.get cfg1.initial in + let cfg2initial = Option.get cfg2.initial in + let cfg1terminal = Option.get cfg1.terminal in + let cfg2terminal = Option.get cfg2.terminal in + { empty = false; + nodes = NodeSet.union cfg1.nodes cfg2.nodes |> + NodeSet.add entryNode |> + NodeSet.add exitNode; + edges = NodeMap.union (fun _ -> failwith "Failed merging edges of cfg.") + cfg1.edges cfg2.edges |> + NodeMap.add entryNode (cfg1initial, Some cfg2initial) |> + NodeMap.add cfg1terminal (exitNode, None) |> + NodeMap.add cfg2terminal (exitNode, None); + reverseedges = NodeMap.union (fun _ -> failwith "Failed merging edges of cfg.") + cfg1.reverseedges cfg2.reverseedges |> + NodeMap.add_to_list cfg1initial entryNode |> + NodeMap.add_to_list cfg2initial entryNode |> + NodeMap.add_to_list exitNode cfg1terminal |> + NodeMap.add_to_list exitNode cfg2terminal; + initial = Some entryNode; + terminal = Some exitNode; + code = NodeMap.union (fun _ -> failwith "Failed merging code of cfg.") + cfg1.code cfg2.code + } + + let concatCfg (cfg1: t) (cfg2: t) : t = + match (cfg1.empty, cfg2.empty) with + true, _ -> cfg2 + | _, true -> cfg1 + | false, false -> + let cfg1initial = Option.get cfg1.initial in + let cfg2initial = Option.get cfg2.initial in + let cfg1terminal = Option.get cfg1.terminal in + let cfg2terminal = Option.get cfg2.terminal in + { empty = false; + nodes = NodeSet.union cfg1.nodes cfg2.nodes; + edges = NodeMap.union (fun _ -> failwith "Failed merging edges of cfg.") + cfg1.edges cfg2.edges |> + NodeMap.add cfg1terminal (cfg2initial, None); + reverseedges = NodeMap.union (fun _ -> failwith "Failed merging edges of cfg.") + cfg1.reverseedges cfg2.reverseedges |> + NodeMap.add_to_list cfg2initial cfg1terminal; + initial = Some cfg1initial; + terminal = Some cfg2terminal; + code = NodeMap.union (fun _ -> failwith "Failed merging code of cfg.") + cfg1.code cfg2.code + } + + let addToLastNode (newcode: simpleStatements) (cfg: t) : t = + match cfg.empty with + | true -> let newnode = Node.newNode () in + { empty = false; + nodes = NodeSet.singleton newnode; + edges = NodeMap.empty; + reverseedges = NodeMap.empty; + initial = Some newnode; + terminal = Some newnode; + code = NodeMap.singleton newnode [newcode] + } + | false -> + let prevcfgterminal = Option.get cfg.terminal in + { cfg with + code = (NodeMap.add_to_list + prevcfgterminal + newcode + cfg.code) } + + let pp (ppf) (c: t) : unit = + Printf.fprintf ppf "Nodes' ids: "; + List.iter (fun (x : Node.t) -> Printf.fprintf ppf "%d " x.id) (NodeSet.to_list c.nodes); + Printf.fprintf ppf "\n"; + + Printf.fprintf ppf "Nodes' edges:\n"; + List.iter (fun ((n, (a, b)) : (Node.t * (Node.t * Node.t option))) : unit -> + match b with None -> Printf.fprintf ppf "\t%d -> %d\n" n.id a.id + | Some b -> Printf.fprintf ppf "\t%d -> %d, %d\n" n.id a.id b.id + ) (NodeMap.to_list c.edges); + Printf.fprintf ppf "\n"; + + Printf.fprintf ppf "Nodes' back edges:\n"; + List.iter (fun ((n, xs) : (Node.t * (Node.t list))) : unit -> + Printf.fprintf ppf "\t%d -> " n.id; + List.iter (fun (x: Node.t) -> Printf.fprintf ppf "%d, " x.id) xs; + Printf.fprintf ppf "\n" + ) (NodeMap.to_list c.reverseedges); + Printf.fprintf ppf "\n"; + + Printf.fprintf ppf "Initial node's id: "; + Printf.fprintf ppf "%d" ((Option.get c.initial).id); + Printf.fprintf ppf "\n"; + + Printf.fprintf ppf "Terminal node's id: "; + Printf.fprintf ppf "%d" ((Option.get c.terminal).id); + Printf.fprintf ppf "\n"; + + Printf.fprintf ppf "Code:\n"; + List.iter (fun ((n, stms) : Node.t * simpleStatements list) : unit -> + Printf.fprintf ppf "\tid %d --> %a\n%!" n.id printSimpleStatements (List.rev stms) + ) (NodeMap.to_list c.code); + Printf.fprintf ppf "\n"; +end +;; + + +let rec convert_c (prevcfg: Cfg.t) (prg: Types.c_exp) : Cfg.t = + match prg with + | Skip -> prevcfg |> Cfg.addToLastNode SimpleSkip + | Assignment (x, a) -> prevcfg |> Cfg.addToLastNode (SimpleAssignment (x, convert_a a)) + | Sequence (c1, c2) -> + let cfg1 = convert_c prevcfg c1 in + let cfg2 = convert_c cfg1 c2 in + cfg2 + | If (b, c1, c2) -> + let convertedb = convert_b b in + let cfg1 = convert_c (Cfg.newCfg ()) c1 in + let cfg2 = convert_c (Cfg.newCfg ()) c2 in + let entrynode = Node.newNode () in + let exitnode = Node.newNode () in + let newcfg = Cfg.mergeCfg cfg1 cfg2 entrynode exitnode in + let mergedcfg = Cfg.concatCfg prevcfg newcfg in + { mergedcfg with + code = mergedcfg.code |> + NodeMap.add_to_list entrynode (SimpleGuard convertedb) |> + NodeMap.add_to_list exitnode (SimpleSkip) } + | While (b, c) -> + let convertedb = convert_b b in + let cfg = convert_c (Cfg.newCfg ()) c in + let cfginitial = Option.get cfg.initial in + let cfgterminal = Option.get cfg.terminal in + let entrynode = Node.newNode () in + let guardnode = Node.newNode () in + let exitnode = Node.newNode () in + { empty = false; + nodes = cfg.nodes |> + NodeSet.add entrynode |> + NodeSet.add guardnode |> + NodeSet.add exitnode; + edges = cfg.edges |> + NodeMap.add entrynode (guardnode, None) |> + NodeMap.add guardnode (cfginitial, Some exitnode) |> + NodeMap.add cfgterminal (guardnode, None); + reverseedges = cfg.reverseedges |> + NodeMap.add_to_list guardnode entrynode |> + NodeMap.add_to_list cfginitial guardnode |> + NodeMap.add_to_list exitnode guardnode |> + NodeMap.add_to_list guardnode cfgterminal; + initial = Some entrynode; + terminal = Some exitnode; + code = NodeMap.add_to_list guardnode (SimpleGuard (convertedb)) cfg.code |> + NodeMap.add_to_list exitnode (SimpleSkip) + } |> Cfg.concatCfg prevcfg + | For (assignment, guard, increment, body) -> + let cfgassignment = convert_c (Cfg.newCfg ()) assignment in + let convertedguard = convert_b guard in + let cfgincrement = convert_c (Cfg.newCfg ()) increment in + let cfgbody = convert_c (Cfg.newCfg ()) body in + + let prevassignment = Cfg.concatCfg prevcfg cfgassignment in + let bodyincrement = Cfg.concatCfg cfgbody cfgincrement in + + let cfginitial = Option.get bodyincrement.initial in + let cfgterminal = Option.get bodyincrement.terminal in + + let guardnode = Node.newNode () in + let exitnode = Node.newNode () in + { empty = false; + nodes = bodyincrement.nodes |> + NodeSet.add guardnode |> + NodeSet.add exitnode; + edges = bodyincrement.edges |> + NodeMap.add guardnode (cfginitial, Some exitnode) |> + NodeMap.add cfgterminal (guardnode, None); + reverseedges = bodyincrement.reverseedges |> + NodeMap.add_to_list cfginitial guardnode |> + NodeMap.add_to_list exitnode guardnode |> + NodeMap.add_to_list guardnode cfgterminal; + initial = Some guardnode; + terminal = Some exitnode; + code = NodeMap.add_to_list guardnode (SimpleGuard (convertedguard)) bodyincrement.code |> + NodeMap.add_to_list exitnode (SimpleSkip) + } |> Cfg.concatCfg prevassignment + +and convert_b (prg: Types.b_exp) : simpleBoolean = + match prg with + | Boolean (b) -> SimpleBoolean b + | BAnd (b1, b2) -> SimpleBAnd (convert_b b1, convert_b b2) + | BOr (b1, b2) -> SimpleBOr (convert_b b1, convert_b b2) + | BNot (b) -> SimpleBNot (convert_b b) + | BCmp (a1, a2) -> SimpleBCmp (convert_a a1, convert_a a2) + | BCmpLess (a1, a2) -> SimpleBCmpLess (convert_a a1, convert_a a2) + | BCmpLessEq (a1, a2) -> SimpleBCmpLessEq (convert_a a1, convert_a a2) + | BCmpGreater (a1, a2) -> SimpleBCmpGreater (convert_a a1, convert_a a2) + | BCmpGreaterEq (a1, a2) -> SimpleBCmpGreaterEq (convert_a a1, convert_a a2) + +and convert_a (prg: Types.a_exp) : simpleArithmetic = + match prg with + | Variable x -> SimpleVariable x + | Integer n -> SimpleInteger n + | Plus (a1, a2) -> SimplePlus (convert_a a1, convert_a a2) + | Minus (a1, a2) -> SimpleMinus (convert_a a1, convert_a a2) + | Times (a1, a2) -> SimpleTimes (convert_a a1, convert_a a2) + | Division (a1, a2) -> SimpleDivision (convert_a a1, convert_a a2) + | Modulo (a1, a2) -> SimpleModulo (convert_a a1, convert_a a2) + | Power (a1, a2) -> SimplePower (convert_a a1, convert_a a2) + | PowerMod (a1, a2, a3) -> SimplePowerMod (convert_a a1, convert_a a2, convert_a a3) + | Rand (a) -> SimpleRand (convert_a a) + +let convert (prg: Types.p_exp) : Cfg.t = + match prg with + | Main (_, _, exp) -> + convert_c (Cfg.newCfg ()) exp diff --git a/lib/miniImp/Cfg.mli b/lib/miniImp/Cfg.mli new file mode 100644 index 0000000..46a0f7a --- /dev/null +++ b/lib/miniImp/Cfg.mli @@ -0,0 +1,40 @@ +type simpleStatements = + | SimpleSkip + | SimpleAssignment of Types.variable * simpleArithmetic + | SimpleGuard of simpleBoolean +and simpleBoolean = + | SimpleBoolean of bool + | SimpleBAnd of simpleBoolean * simpleBoolean + | SimpleBOr of simpleBoolean * simpleBoolean + | SimpleBNot of simpleBoolean + | SimpleBCmp of simpleArithmetic * simpleArithmetic + | SimpleBCmpLess of simpleArithmetic * simpleArithmetic + | SimpleBCmpLessEq of simpleArithmetic * simpleArithmetic + | SimpleBCmpGreater of simpleArithmetic * simpleArithmetic + | SimpleBCmpGreaterEq of simpleArithmetic * simpleArithmetic +and simpleArithmetic = + | SimpleVariable of Types.variable + | SimpleInteger of int + | SimplePlus of simpleArithmetic * simpleArithmetic + | SimpleMinus of simpleArithmetic * simpleArithmetic + | SimpleTimes of simpleArithmetic * simpleArithmetic + | SimpleDivision of simpleArithmetic * simpleArithmetic + | SimpleModulo of simpleArithmetic * simpleArithmetic + | SimplePower of simpleArithmetic * simpleArithmetic + | SimplePowerMod of simpleArithmetic * simpleArithmetic * simpleArithmetic + | SimpleRand of simpleArithmetic + +module Node : sig + type t + val compare : t -> t -> int +end + +module NodeMap : Map.S with type key = Node.t +module NodeSet : Set.S with type elt = Node.t + +module Cfg : sig + type t + val pp : out_channel -> t -> unit +end + +val convert : Types.p_exp -> Cfg.t diff --git a/lib/miniImp/Lexer.mll b/lib/miniImp/Lexer.mll new file mode 100644 index 0000000..89508a5 --- /dev/null +++ b/lib/miniImp/Lexer.mll @@ -0,0 +1,92 @@ +{ + open Parser + exception LexingError of string + + let create_hashtable size init = + let tbl = Hashtbl.create size in + List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + + let keyword_table = + let mapping = [ + ("as", AS); + ("def", DEF); + ("do", DO); + ("else", ELSE); + ("false", BOOL(false)); + ("for", FOR); + ("if", IF); + ("input", INPUT); + ("main", MAIN); + ("not", BNOT); + ("output", OUTPUT); + ("powmod", POWERMOD); + ("rand", RAND); + ("skip", SKIP); + ("then", THEN); + ("true", BOOL(true)); + ("while", WHILE); + ("with", WITH); + ] + in create_hashtable (List.length mapping) mapping +} + +let digit = ['0'-'9'] +let alpha = ['a'-'z' 'A'-'Z'] +let white = [' ' '\t']+ | '\r' | '\n' | "\r\n" + +let integer = (digit)(digit*) +let var = (alpha|'_') (alpha|digit|'_')* + +let symbols = ['!'-'/' ':'-'?' '[' ']' '^' '{'-'}' '~'] + +(* lexing rules *) +rule read = parse + | white {read lexbuf} + | var as v { + match Hashtbl.find_opt keyword_table v with + | Some keyword -> keyword + | None -> VARIABLE(v) + } + | "%" {MODULO} + | "&&" {BAND} + | "(" {LEFTPAR} + | ")" {RIGHTPAR} + | "*" {TIMES} + | "+" {PLUS} + | "," {COMMA} + | "-" {MINUS} + | "/" {DIVISION} + | ":=" {ASSIGNMENT} + | ";" {SEQUENCE} + | "<" {BCMPLESS} + | "<=" {BCMPLESSEQ} + | "==" {BCMP} + | ">" {BCMPGREATER} + | ">=" {BCMPGREATEREQ} + | "^" {POWER} + | "||" {BOR} + | integer as i {INT(int_of_string i)} + | "(*" {comments 0 lexbuf} + | eof {EOF} + | _ { + raise + (LexingError + (Printf.sprintf + "Error scanning %s on line %d at char %d" + (Lexing.lexeme lexbuf) + (lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum) + (lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum) + ))} +and comments level = parse + | "*)" {if level = 0 + then read lexbuf + else comments (level-1) lexbuf} + | "(*" {comments (level+1) lexbuf} + | _ {comments level lexbuf} + | eof {raise (LexingError ("Comment is not closed"))} + + +{ + let lex = read +} diff --git a/lib/miniImp/Parser.mly b/lib/miniImp/Parser.mly new file mode 100644 index 0000000..e52eb52 --- /dev/null +++ b/lib/miniImp/Parser.mly @@ -0,0 +1,85 @@ +(* code to be copied in the scanner module *) +(* +*) +%{ + open Types +%} + +(* tokens *) +%token MAIN DEF WITH INPUT OUTPUT AS SKIP ASSIGNMENT SEQUENCE IF THEN ELSE WHILE +%token FOR DO COMMA LEFTPAR RIGHTPAR +%token PLUS MINUS TIMES DIVISION MODULO POWER POWERMOD RAND +%token BAND BOR BNOT BCMP BCMPLESS BCMPLESSEQ BCMPGREATER BCMPGREATEREQ +%token BOOL +%token INT +%token VARIABLE +%token EOF + +%type cexpp +%type bexpp +%type aexpp +%type prg + +(* start nonterminal *) +%start prg + +(* associativity in order of precedence *) +%left lowest +%left SEQUENCE +%left ELSE +%left PLUS MINUS BOR BAND +%left BNOT +%left DIVISION +%left MODULO +%left TIMES +%left POWER +%left DO + +%% + +(* grammar *) +prg: + | DEF; MAIN; WITH; INPUT; a = VARIABLE; OUTPUT; b = VARIABLE; AS; t = cexpp; EOF + {Main (a, b, t)} // def main with input a output b as t +cexpp: + | SKIP {Skip} // skip + | a = VARIABLE; ASSIGNMENT; body = aexpp + {Assignment (a, body)} // a := body + | t1 = cexpp; SEQUENCE; t2 = cexpp %prec lowest + {Sequence (t1, t2)} // t1; t2 + | t = cexpp; SEQUENCE {t} // t; + | IF; guard = bexpp; THEN; body1 = cexpp; ELSE; body2 = cexpp + {If (guard, body1, body2)} // if ... then ... else ... + | WHILE; guard = bexpp; DO; body = cexpp; + {While (guard, body)} // while ... do ... + | FOR; LEFTPAR; ass = cexpp; COMMA; guard = bexpp; COMMA; iter = cexpp; RIGHTPAR; + DO; body = cexpp; + {For (ass, guard, iter, body)} // for (..., ..., ...) do ... + | LEFTPAR; t = cexpp; RIGHTPAR {t} // (...) +bexpp: + | b = BOOL {Boolean (b)} // true, false + | b1 = bexpp; BAND; b2 = bexpp {BAnd (b1, b2)} // && + | b1 = bexpp; BOR; b2 = bexpp {BOr (b1, b2)} // || + | BNOT; b = bexpp {BNot (b)} // not + | a1 = aexpp; BCMP; a2 = aexpp {BCmp (a1, a2)} // == + | a1 = aexpp; BCMPLESS; a2 = aexpp {BCmpLess (a1, a2)} // < + | a1 = aexpp; BCMPLESSEQ; a2 = aexpp {BCmpLessEq (a1, a2)} // <= + | a1 = aexpp; BCMPGREATER; a2 = aexpp {BCmpGreater (a1, a2)} // > + | a1 = aexpp; BCMPGREATEREQ; a2 = aexpp {BCmpGreaterEq (a1, a2)} // >= + | LEFTPAR; b = bexpp; RIGHTPAR {b} // (b) +aexpp: + | a = VARIABLE {Variable (a)} + | i = INT {Integer (i)} + | t1 = aexpp; PLUS; t2 = aexpp {Plus (t1, t2)} // + + | t1 = aexpp; MINUS; t2 = aexpp {Minus (t1, t2)} // - + | MINUS; i = INT {Integer (-i)} + | t1 = aexpp; TIMES; t2 = aexpp {Times (t1, t2)} // * + | t1 = aexpp; DIVISION; t2 = aexpp {Division (t1, t2)} // / + | t1 = aexpp; MODULO; t2 = aexpp {Modulo (t1, t2)} // % + | t1 = aexpp; POWER; t2 = aexpp {Power (t1, t2)} // ^ + | POWERMOD; LEFTPAR; t1 = aexpp; COMMA; + t2 = aexpp; COMMA; + t3 = aexpp; RIGHTPAR + {PowerMod (t1, t2, t3)} // powmod(..., ..., ...) + | RAND; LEFTPAR; t = aexpp; RIGHTPAR {Rand (t)} // rand() + | LEFTPAR; a = aexpp; RIGHTPAR {a} // (a) diff --git a/lib/miniImp/Semantics.ml b/lib/miniImp/Semantics.ml index 1505899..b783715 100644 --- a/lib/miniImp/Semantics.ml +++ b/lib/miniImp/Semantics.ml @@ -4,139 +4,153 @@ module Utility = Utility;; Random.self_init () -let rec evaluate (mem: memory) (command: c_exp) = +let (let*) = Result.bind + +let rec evaluate (mem: memory) (command: c_exp) : (memory, [> error]) result = match command with - Skip -> mem - | Assignment (v, exp_a) -> { - (* Map.add replaces the previeus value *) - assignments = VariableMap.add v (evaluate_a mem exp_a) mem.assignments + Skip -> Ok mem + | Assignment (v, exp_a) -> + let* vval = evaluate_a mem exp_a in + Ok { + (* Map.add replaces the previus value *) + assignments = VariableMap.add v vval mem.assignments } | Sequence (exp_c1, exp_c2) -> ( - let mem2 = evaluate mem exp_c1 in + let* mem2 = evaluate mem exp_c1 in evaluate mem2 exp_c2 ) | If (exp_b, exp_c1, exp_c2) -> ( - if evaluate_b mem exp_b then + let* guard = evaluate_b mem exp_b in + if guard then evaluate mem exp_c1 else evaluate mem exp_c2 ) | While (exp_b, exp_c) -> ( - if evaluate_b mem exp_b then - let mem2 = evaluate mem exp_c in + let* guard = evaluate_b mem exp_b in + if guard then + let* mem2 = evaluate mem exp_c in evaluate mem2 command else - mem + Ok mem ) | For (exp_c1, exp_b, exp_c2, body_c) -> ( - let mem2 = evaluate mem exp_c1 in - let rec f localmem = - if (evaluate_b localmem exp_b) - then f ( - let tmpmem = (evaluate localmem body_c) in - (evaluate tmpmem exp_c2)) - else localmem + let* mem2 = evaluate mem exp_c1 in + let rec f (localmem: memory) : (memory, [> error]) result = + let* guard = (evaluate_b localmem exp_b) in + if guard + then + let* stepmem = evaluate localmem body_c in + let* incrementmem = evaluate stepmem exp_c2 in + f incrementmem + else Ok localmem in f mem2 ) -and evaluate_a (mem: memory) (exp_a: a_exp) = + +and evaluate_a (mem: memory) (exp_a: a_exp) : (int, [> error]) result = match exp_a with Variable v -> ( match VariableMap.find_opt v mem.assignments with - None -> raise (AbsentAssignment ("The variable " ^ v ^ " is not defined.")) - | Some a -> a + None -> Error (`AbsentAssignment ("The variable " ^ v ^ " is not defined.")) + | Some a -> Ok a ) - | Integer n -> n + | Integer n -> Ok n | Plus (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val + exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val + exp_a2val) ) | Minus (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val - exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val - exp_a2val) ) | Times (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val * exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val * exp_a2val) ) | Division (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in try - exp_a1val / exp_a2val - with Division_by_zero -> raise (DivisionByZero "Dividing by zero") + Ok (exp_a1val / exp_a2val) + with Division_by_zero -> Error (`DivisionByZero "Dividing by zero") ) | Modulo (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val mod exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val mod exp_a2val) ) | Power (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - Utility.pow exp_a1val exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (Utility.pow exp_a1val exp_a2val) ) | PowerMod (exp_a1, exp_a2, exp_a3) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - let exp_a3val = evaluate_a mem exp_a3 in - Utility.powmod exp_a1val exp_a3val exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + let* exp_a3val = evaluate_a mem exp_a3 in + Ok (Utility.powmod exp_a1val exp_a3val exp_a2val) ) | Rand (exp_a) -> ( - Random.int (evaluate_a mem exp_a) + let* exp_aval = evaluate_a mem exp_a in + Ok (Random.int exp_aval) ) -and evaluate_b (mem: memory) (exp_b: b_exp) = + + +and evaluate_b (mem: memory) (exp_b: b_exp) : (bool, [> error]) result = match exp_b with - Boolean b -> b + Boolean b -> Ok b | BAnd (exp_b1, exp_b2) -> ( - let exp_b1val = evaluate_b mem exp_b1 in - let exp_b2val = evaluate_b mem exp_b2 in - exp_b1val && exp_b2val + let* exp_b1val = evaluate_b mem exp_b1 in + let* exp_b2val = evaluate_b mem exp_b2 in + Ok (exp_b1val && exp_b2val) ) | BOr (exp_b1, exp_b2) -> ( - let exp_b1val = evaluate_b mem exp_b1 in - let exp_b2val = evaluate_b mem exp_b2 in - exp_b1val || exp_b2val + let* exp_b1val = evaluate_b mem exp_b1 in + let* exp_b2val = evaluate_b mem exp_b2 in + Ok (exp_b1val || exp_b2val) ) | BNot (exp_b) -> ( - not (evaluate_b mem exp_b) + let* exp_bval = evaluate_b mem exp_b in + Ok (not exp_bval) ) | BCmp (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val = exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val = exp_a2val) ) | BCmpLess (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val < exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val < exp_a2val) ) | BCmpLessEq (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val <= exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val <= exp_a2val) ) | BCmpGreater (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val > exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val > exp_a2val) ) | BCmpGreaterEq (exp_a1, exp_a2) -> ( - let exp_a1val = evaluate_a mem exp_a1 in - let exp_a2val = evaluate_a mem exp_a2 in - exp_a1val >= exp_a2val + let* exp_a1val = evaluate_a mem exp_a1 in + let* exp_a2val = evaluate_a mem exp_a2 in + Ok (exp_a1val >= exp_a2val) ) -let reduce (program: p_exp) (iin : int) = +let reduce (program: p_exp) (iin : int) : (int, [> error]) result = match program with Main (vin, vout, expression) -> ( let mem : memory = {assignments = (VariableMap.empty |> VariableMap.add vin iin)} in - match VariableMap.find_opt vout (evaluate mem expression).assignments with - None -> raise (AbsentAssignment ("The output variable is not defined (" ^ vout ^ ")")) - | Some a -> a + let* resultmem : memory = evaluate mem expression in + match VariableMap.find_opt vout resultmem.assignments with + None -> Error (`AbsentAssignment ("The output variable is not defined (" ^ vout ^ ")")) + | Some a -> Ok a ) diff --git a/lib/miniImp/Semantics.mli b/lib/miniImp/Semantics.mli index ac04fd0..b488ded 100644 --- a/lib/miniImp/Semantics.mli +++ b/lib/miniImp/Semantics.mli @@ -1,3 +1,3 @@ open Types -val reduce : p_exp -> int -> int +val reduce : p_exp -> int -> (int, [> Types.error]) result diff --git a/lib/miniImp/Types.ml b/lib/miniImp/Types.ml index 8bd81cf..db449d1 100644 --- a/lib/miniImp/Types.ml +++ b/lib/miniImp/Types.ml @@ -8,13 +8,13 @@ and c_exp = | Sequence of c_exp * c_exp (* c; c *) | If of b_exp * c_exp * c_exp (* if b then c else c *) | While of b_exp * c_exp (* while b do c *) - | For of c_exp * b_exp * c_exp * c_exp (* for c; b; c do c *) + | For of c_exp * b_exp * c_exp * c_exp (* for (c; b; c) do c *) and b_exp = Boolean of bool (* v *) - | BAnd of b_exp * b_exp (* b and b *) - | BOr of b_exp * b_exp (* b or b *) + | BAnd of b_exp * b_exp (* b && b *) + | BOr of b_exp * b_exp (* b || b *) | BNot of b_exp (* not b *) - | BCmp of a_exp * a_exp (* a = a *) + | BCmp of a_exp * a_exp (* a == a *) | BCmpLess of a_exp * a_exp (* a < a *) | BCmpLessEq of a_exp * a_exp (* a <= a *) | BCmpGreater of a_exp * a_exp (* a > a *) @@ -38,5 +38,7 @@ type memory = { assignments: int VariableMap.t } -exception AbsentAssignment of string -exception DivisionByZero of string +type error = [ + `AbsentAssignment of string + | `DivisionByZero of string +] diff --git a/lib/miniImp/Types.mli b/lib/miniImp/Types.mli index fe60c81..92a9a35 100644 --- a/lib/miniImp/Types.mli +++ b/lib/miniImp/Types.mli @@ -8,13 +8,13 @@ and c_exp = | Sequence of c_exp * c_exp (* c; c *) | If of b_exp * c_exp * c_exp (* if b then c else c *) | While of b_exp * c_exp (* while b do c *) - | For of c_exp * b_exp * c_exp * c_exp (* for c; b; c do c *) + | For of c_exp * b_exp * c_exp * c_exp (* for (c; b; c) do c *) and b_exp = Boolean of bool (* v *) - | BAnd of b_exp * b_exp (* b and b *) - | BOr of b_exp * b_exp (* b or b *) + | BAnd of b_exp * b_exp (* b && b *) + | BOr of b_exp * b_exp (* b || b *) | BNot of b_exp (* not b *) - | BCmp of a_exp * a_exp (* a = a *) + | BCmp of a_exp * a_exp (* a == a *) | BCmpLess of a_exp * a_exp (* a < a *) | BCmpLessEq of a_exp * a_exp (* a <= a *) | BCmpGreater of a_exp * a_exp (* a > a *) @@ -38,5 +38,7 @@ type memory = { assignments: int VariableMap.t } -exception AbsentAssignment of string -exception DivisionByZero of string +type error = [ + `AbsentAssignment of string + | `DivisionByZero of string +] diff --git a/lib/miniImp/dune b/lib/miniImp/dune new file mode 100644 index 0000000..37cb1c9 --- /dev/null +++ b/lib/miniImp/dune @@ -0,0 +1,16 @@ +(ocamllex Lexer) + +(menhir + (modules Parser) + (explain true) + (infer true) + (flags --dump --table) + ) + +(library + (name miniImp) + (public_name miniImp) + (modules Lexer Parser Types Semantics Cfg) + (libraries utility menhirLib)) + +(include_subdirs qualified) diff --git a/lib/utility/dune b/lib/utility/dune new file mode 100644 index 0000000..5b02a35 --- /dev/null +++ b/lib/utility/dune @@ -0,0 +1,5 @@ +(library + (name utility) + (public_name utility)) + +(include_subdirs qualified) \ No newline at end of file diff --git a/lib/utility.ml b/lib/utility/utility.ml similarity index 100% rename from lib/utility.ml rename to lib/utility/utility.ml diff --git a/lib/utility.mli b/lib/utility/utility.mli similarity index 100% rename from lib/utility.mli rename to lib/utility/utility.mli diff --git a/test/dune b/test/dune index 6fa18f7..dbab5bc 100644 --- a/test/dune +++ b/test/dune @@ -1,11 +1,19 @@ (test (name testingImp) - (libraries lang)) + (libraries miniImp)) + +(test + (name testingImpParser) + (libraries miniImp)) (test (name testingFun) - (libraries lang)) + (libraries miniFun)) (test (name testingTypeFun) - (libraries lang)) \ No newline at end of file + (libraries miniFun)) + +(test + (name testingTypeFunParser) + (libraries miniFun)) \ No newline at end of file diff --git a/test/testingFun.ml b/test/testingFun.ml index 2067838..9977d44 100644 --- a/test/testingFun.ml +++ b/test/testingFun.ml @@ -1,59 +1,70 @@ -open Lang.MiniFun -open Lang.MiniFunTypes +open MiniFun.Semantics +open MiniFun.Types (* -------------------------------------------------------------------------- *) (* Identity program *) let program = Function - (["a"], - FunctionType ([IntegerType], IntegerType), + ("a", + FunctionType (IntegerType, IntegerType), (Variable "a") ) ;; -Printf.printf "Identity program: %d\n" (Result.get_ok (reduce program 1)) +match reduce program 1 with + Ok o -> Printf.printf "Identity program: %d\n" o +| Error _ -> Printf.printf "Identity program: error\n" (* -------------------------------------------------------------------------- *) (* Constant program *) let program = Function - (["a"], - FunctionType ([IntegerType], IntegerType), + ("a", + FunctionType (IntegerType, IntegerType), (Integer 1) ) ;; -Printf.printf "Constant program: %d\n" (Result.get_ok (reduce program 10)) +match reduce program 10 with + Ok o -> Printf.printf "Constant program: %d\n" o +| Error _ -> Printf.printf "Constant program: error\n" (* -------------------------------------------------------------------------- *) (* Partial application of function program *) let program = LetIn ("f", - (Function (["x"; "y"], - FunctionType ([IntegerType; IntegerType], IntegerType), - Plus (Variable "x", Variable "y"))), - (Application (Variable "f", [Integer 3])) + (Function ("x", + FunctionType (IntegerType, FunctionType (IntegerType, IntegerType)), + (Function ("y", FunctionType (IntegerType, IntegerType), + Plus (Variable "x", Variable "y")) + ) + )), + (Application (Variable "f", Integer 3)) ) ;; -Printf.printf "Partial application of function program: %d\n" (Result.get_ok (reduce program 2)) +match reduce program 2 with + Ok o -> Printf.printf "Partial application of function program: %d\n" o +| Error _ -> Printf.printf "Partial application of function program: error\n" (* -------------------------------------------------------------------------- *) (* Partial application of function program *) let program = LetFun ("f", - ["x"], - FunctionType ([IntegerType], IntegerType), - (Function (["y"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), + (Function ("y", + FunctionType (IntegerType, IntegerType), Plus (Variable "x", Variable "y"))), - (Application (Variable "f", [Integer 3])) + (Application (Variable "f", Integer 3)) ) ;; -Printf.printf "Partial application of function program: %d\n" (Result.get_ok (reduce program 3)) +match reduce program 3 with + Ok o -> Printf.printf "Partial application of function program: %d\n" o +| Error _ -> Printf.printf "Partial application of function program: error\n" (* -------------------------------------------------------------------------- *) (* Passing functions to functions program *) @@ -61,18 +72,18 @@ let program = LetIn ("f", (Function ( - ["z"], - FunctionType ([FunctionType ([IntegerType], IntegerType)], IntegerType), + "z", + FunctionType (FunctionType (IntegerType, IntegerType), IntegerType), (Function ( - ["y"], - FunctionType ([FunctionType ([IntegerType], IntegerType)], IntegerType), + "y", + FunctionType (FunctionType (IntegerType, IntegerType), IntegerType), Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), (IfThenElse ( CmpLess (Variable "x", Integer 0), - (Application (Variable "y", [Variable "x"])), - (Application (Variable "z", [Variable "x"])) + (Application (Variable "y", Variable "x")), + (Application (Variable "z", Variable "x")) ))) )) )), @@ -80,82 +91,100 @@ let program = ( (Application (Variable "f", - [Function (["x"], FunctionType ([IntegerType], IntegerType), Plus (Variable "x", Integer 1))] + Function ("x", FunctionType (IntegerType, IntegerType), Plus (Variable "x", Integer 1)) ) ), - [Function (["x"], FunctionType ([IntegerType], IntegerType), Minus (Variable "x", Integer 1))] + Function ("x", FunctionType (IntegerType, IntegerType), Minus (Variable "x", Integer 1)) ) ) ) ;; -Printf.printf "Passing functions to functions program 1: %d\n" (Result.get_ok (reduce program (3))); -Printf.printf "Passing functions to functions program 2: %d\n" (Result.get_ok (reduce program (-3))) +match reduce program (3) with + Ok o -> Printf.printf "Passing functions to functions program 1: %d\n" o +| Error _ -> Printf.printf "Passing functions to functions program 1: error\n";; + +match reduce program (-3) with + Ok o -> Printf.printf "Passing functions to functions program 2: %d\n" o +| Error _ -> Printf.printf "Passing functions to functions program 2: error\n" (* -------------------------------------------------------------------------- *) (* Recursive function program *) let program = LetFun ("f", - ["x"], - FunctionType ([IntegerType], IntegerType), - (IfThenElse (CmpLess (Variable "x", Integer 2),Integer 1, Plus (Variable "x", Application (Variable "f", [Minus (Variable "x", Integer 1)])))), + "x", + FunctionType (IntegerType, IntegerType), + (IfThenElse (CmpLess (Variable "x", Integer 2),Integer 1, Plus (Variable "x", Application (Variable "f", Minus (Variable "x", Integer 1))))), (Variable "f") ) ;; -Printf.printf "Recursive function program: %d\n" (Result.get_ok (reduce program 10)) +match reduce program 10 with + Ok o -> Printf.printf "Recursive function program: %d\n" o +| Error _ -> Printf.printf "Recursive function program: error\n" (* -------------------------------------------------------------------------- *) (* Scope program *) let program = LetIn ("f", - (LetIn ("a", Integer 1, (Function (["y"], FunctionType ([IntegerType], IntegerType), Plus (Variable "y", Variable "a"))))), + (LetIn ("a", Integer 1, (Function ("y", FunctionType (IntegerType, IntegerType), Plus (Variable "y", Variable "a"))))), (LetIn ("a", Integer 2, Variable "f")) ) ;; -Printf.printf "Scope program: %d\n" (Result.get_ok (reduce program 4)) +match reduce program 4 with + Ok o -> Printf.printf "Scope program: %d\n" o +| Error _ -> Printf.printf "Scope program: error\n" (* -------------------------------------------------------------------------- *) (* Factorial program *) let program = LetFun ( "f", - ["x"], - FunctionType ([IntegerType], IntegerType), - (IfThenElse (CmpLessEq (Variable "x", Integer 0), Integer 1, Times (Variable "x", Application (Variable "f", [Minus (Variable "x", Integer 1)])))), + "x", + FunctionType (IntegerType, IntegerType), + (IfThenElse (CmpLessEq (Variable "x", Integer 0), Integer 1, Times (Variable "x", Application (Variable "f", Minus (Variable "x", Integer 1))))), (Variable "f") ) ;; -Printf.printf "Factorial program: %d\n" (Result.get_ok (reduce program 10)) -;; +match reduce program 10 with + Ok o -> Printf.printf "Factorial program: %d\n" o +| Error _ -> Printf.printf "Factorial program: error\n" (* -------------------------------------------------------------------------- *) (* Hailstone sequence's lenght program *) let program = + LetFun ( "collatz", - ["n"; "count"], - FunctionType ([IntegerType; IntegerType], IntegerType), + "input", + FunctionType (TupleType (IntegerType, IntegerType), IntegerType), ( - IfThenElse (BNot (Cmp (Variable "n", Integer 1)), - (IfThenElse (Cmp (Modulo (Variable "n", Integer 2), Integer 0), - Application (Variable "collatz", [Division (Variable "n", Integer 2); Plus (Integer 1, Variable "count")]), - Application (Variable "collatz", [(Plus (Integer 1, Times (Integer 3, Variable "n"))); Plus (Integer 1, Variable "count")]))), - (Variable "count")) + IfThenElse (BNot (Cmp (First (Variable "input"), Integer 1)), + (IfThenElse (Cmp (Modulo (First (Variable "input"), Integer 2), Integer 0), + Application (Variable "collatz", + Tuple ( + Division (First (Variable "input"), Integer 2), + Plus (Integer 1, Second (Variable "input")))), + Application (Variable "collatz", + Tuple ( + Plus (Integer 1, Times (Integer 3, First (Variable "input"))), + Plus (Integer 1, Second (Variable "input")))))), + (Second (Variable "input"))) ), - (Function (["x"], - FunctionType ([IntegerType], IntegerType), - Application (Variable "collatz", [Variable "x"; Integer 1]))) + (Function ("x", + FunctionType (IntegerType, IntegerType), + Application (Variable "collatz", Tuple (Variable "x", Integer 1)))) ) ;; -Printf.printf "Hailstone sequence's lenght program: %d\n" (Result.get_ok (reduce program 77031)) -;; +match reduce program 77031 with + Ok o -> Printf.printf "Hailstone sequence's lenght program: %d\n" o +| Error _ -> Printf.printf "Hailstone sequence's lenght program: error\n" (* -------------------------------------------------------------------------- *) (* Sum multiples of 3 and 5 program *) @@ -163,55 +192,81 @@ Printf.printf "Hailstone sequence's lenght program: %d\n" (Result.get_ok (reduce let program = LetFun ( "sum", - ["n"], - FunctionType ([IntegerType], IntegerType), + "n", + FunctionType (IntegerType, IntegerType), (IfThenElse ((BOr (Cmp (Modulo (Variable "n", Integer 3), Integer 0), Cmp (Modulo (Variable "n", Integer 5), Integer 0))), - Plus (Variable "n", Application (Variable "sum", [Minus (Variable "n", Integer 1)])), + Plus (Variable "n", Application (Variable "sum", Minus (Variable "n", Integer 1))), (IfThenElse ((CmpLessEq (Variable "n", Integer 1)), (Integer 0), - (Application (Variable "sum", [Minus (Variable "n", Integer 1)]))) + (Application (Variable "sum", Minus (Variable "n", Integer 1)))) )) ), (Variable "sum") ) ;; -Printf.printf "Sum multiples of 3 and 5 program: %d\n" (Result.get_ok (reduce program 12345)) -;; +match reduce program 12345 with + Ok o -> Printf.printf "Sum multiples of 3 and 5 program: %d\n" o +| Error _ -> Printf.printf "Sum multiples of 3 and 5 program: error\n" (* -------------------------------------------------------------------------- *) (* Rand program *) let program = Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), Rand (Variable "x") ) ;; -Printf.printf "Rand program: %b\n" ((Result.get_ok (reduce program 10) < 10)) -;; +match reduce program 10 with + Ok o -> if o < 10 then Printf.printf "Rand program: %b\n" true + else Printf.printf "Rand program: %b\n" false +| Error _ -> Printf.printf "Rand program: error\n" (* -------------------------------------------------------------------------- *) (* Fibonacci program *) let program = LetFun ( "fib", - ["i"; "a"; "b"], - FunctionType ([IntegerType; IntegerType; IntegerType], IntegerType), - (IfThenElse (Cmp (Variable "i", Integer 0), - Variable "a", - Application (Variable "fib", [Minus (Variable "i", Integer 1); - Variable "b"; - Plus (Variable "a", Variable "b")]) - )), - Function (["x"], - FunctionType ([IntegerType], IntegerType), - (Application (Variable "fib", [Variable "x"; Integer 0; Integer 1]))) + "i", + FunctionType (IntegerType, FunctionType (IntegerType, FunctionType (IntegerType, IntegerType))), + Function ( + "a", + FunctionType (IntegerType, FunctionType (IntegerType, IntegerType)), + Function ( + "b", + FunctionType (IntegerType, IntegerType), + (IfThenElse (Cmp (Variable "i", Integer 0), + Variable "a", + Application ( + Application ( + Application ( + Variable "fib", + Minus (Variable "i", Integer 1)), + Variable "b"), + Plus (Variable "a", Variable "b") + ) + )) + ) + ), + Function ("x", + FunctionType (IntegerType, IntegerType), + Application ( + Application ( + Application ( + Variable "fib", + Variable "x" + ), + Integer 0 + ), + Integer 1 + ) + ) ) - ;; -Printf.printf "Fibonacci program: %d\n" (Result.get_ok (reduce program 48)) -;; +match reduce program 48 with + Ok o -> Printf.printf "Fibonacci program: %d\n" o +| Error _ -> Printf.printf "Fibonacci program: error\n" diff --git a/test/testingImp.expected b/test/testingImp.expected index 28a758d..bd227e4 100644 --- a/test/testingImp.expected +++ b/test/testingImp.expected @@ -5,5 +5,5 @@ Hailstone sequence's lenght program: 351 Sum multiples of 3 and 5 program: 35565945 Rand program: true Fibonacci program: 4807526976 -Miller-Rabin primality test program: 0 -Miller-Rabin primality test program: 1 +Miller-Rabin primality test program 1: 0 +Miller-Rabin primality test program 2: 1 diff --git a/test/testingImp.ml b/test/testingImp.ml index 9bfa08b..d4fcdd5 100644 --- a/test/testingImp.ml +++ b/test/testingImp.ml @@ -1,5 +1,5 @@ -open Lang.MiniImp -open Lang.MiniImpTypes +open MiniImp.Semantics +open MiniImp.Types (* -------------------------------------------------------------------------- *) (* Identity program *) @@ -11,7 +11,12 @@ let program = ) ;; -Printf.printf "Identity program: %d\n" (reduce program 1) +Printf.printf "Identity program: "; +match reduce program 1 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; (* -------------------------------------------------------------------------- *) (* y not defined program *) @@ -28,10 +33,12 @@ let program = ) ;; -try - Printf.printf "y not defined program: %d\n" (reduce program 100) -with AbsentAssignment s -> - Printf.printf "y not defined program: %s\n" s + +Printf.printf "y not defined program: "; +match reduce program 100 with + Ok d -> Printf.printf "error: %d\n" d +| Error `AbsentAssignment msg -> Printf.printf "%s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* -------------------------------------------------------------------------- *) @@ -54,9 +61,14 @@ let program = ) ;; -Printf.printf "Factorial program: %d\n" (reduce program 10) +Printf.printf "Factorial program: "; +match reduce program 10 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; + (* -------------------------------------------------------------------------- *) (* Hailstone sequence's lenght program *) let program = @@ -80,7 +92,11 @@ let program = ) ;; -Printf.printf "Hailstone sequence's lenght program: %d\n" (reduce program 77031) +Printf.printf "Hailstone sequence's lenght program: "; +match reduce program 77031 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* -------------------------------------------------------------------------- *) @@ -106,7 +122,11 @@ let program = ) ;; -Printf.printf "Sum multiples of 3 and 5 program: %d\n" (reduce program 12345) +Printf.printf "Sum multiples of 3 and 5 program: "; +match reduce program 12345 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* -------------------------------------------------------------------------- *) @@ -119,7 +139,11 @@ let program = ) ;; -Printf.printf "Rand program: %b\n" ((reduce program 10) < 10) +Printf.printf "Rand program: "; +match reduce program 10 with + Ok d -> Printf.printf "%b\n" (d < 10) +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* -------------------------------------------------------------------------- *) @@ -149,7 +173,11 @@ let program = ) ;; -Printf.printf "Fibonacci program: %d\n" (reduce program 48) +Printf.printf "Fibonacci program: "; +match reduce program 48 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* -------------------------------------------------------------------------- *) @@ -216,8 +244,16 @@ let program = ;; (* should return 0 because prime *) -Printf.printf "Miller-Rabin primality test program: %d\n" (reduce program 179424673) +Printf.printf "Miller-Rabin primality test program 1: "; +match reduce program 179424673 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; (* should return 1 because not prime *) -Printf.printf "Miller-Rabin primality test program: %d\n" (reduce program 179424675) +Printf.printf "Miller-Rabin primality test program 2: "; +match reduce program 179424675 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg ;; diff --git a/test/testingImpParser.expected b/test/testingImpParser.expected new file mode 100644 index 0000000..bd227e4 --- /dev/null +++ b/test/testingImpParser.expected @@ -0,0 +1,9 @@ +Identity program: 1 +y not defined program: The variable y is not defined. +Factorial program: 3628800 +Hailstone sequence's lenght program: 351 +Sum multiples of 3 and 5 program: 35565945 +Rand program: true +Fibonacci program: 4807526976 +Miller-Rabin primality test program 1: 0 +Miller-Rabin primality test program 2: 1 diff --git a/test/testingImpParser.ml b/test/testingImpParser.ml new file mode 100644 index 0000000..dcacecd --- /dev/null +++ b/test/testingImpParser.ml @@ -0,0 +1,166 @@ +open MiniImp + +let get_result x = + Lexing.from_string x |> Parser.prg Lexer.lex |> Semantics.reduce + +(* -------------------------------------------------------------------------- *) +(* Identity program *) +let program = + "def main with input a output b as b := a" +;; + +Printf.printf "Identity program: "; +match get_result program 1 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* y not defined program *) +let program = + "def main with input a output b as x := 1; b := a + x + y" +;; + +Printf.printf "y not defined program: "; +match get_result program 100 with + Ok d -> Printf.printf "error: %d\n" d +| Error `AbsentAssignment msg -> Printf.printf "%s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Factorial program *) +let program = +"def main with input a output b as + b := 1; + for (i := 1, i <= a, i := i + 1) do + b := b * i; +" +;; + +Printf.printf "Factorial program: "; +match get_result program 10 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Hailstone sequence's lenght program *) +let program = +"def main with input a output b as + b := 1; + while not a == 1 do ( + b := b + 1; + if ((a % 2) == 1) then a := 3 * a + 1 else a := a / 2 + ) +" +;; + +Printf.printf "Hailstone sequence's lenght program: "; +match get_result program 77031 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Sum multiples of 3 and 5 program *) +let program = +"def main with input a output b as + b := 0; + for (i := 0, i <= a, i := i+1) do + if (i % 3 == 0 || i % 5 == 0) then b := b + i; + else skip; +" +;; + +Printf.printf "Sum multiples of 3 and 5 program: "; +match get_result program 12345 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Rand program *) +let program = + "def main with input a output b as b := rand(a)" +;; + +Printf.printf "Rand program: "; +match get_result program 10 with + Ok d -> Printf.printf "%b\n" (d < 10) +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Fibonacci program *) +let program = +"def main with input n output fnext as + fnow := 0; + fnext := 1; + while (n > 1) do ( + tmp := fnow + fnext; + fnow := fnext; + fnext := tmp; + n := n - 1; + ) +" +;; + +Printf.printf "Fibonacci program: "; +match get_result program 48 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* -------------------------------------------------------------------------- *) +(* Miller-Rabin primality test program *) +let program = +"def main with input n output result as + if (n % 2) == 0 then result := 1 + else ( + + result := 0; + s := 0; + while (0 == ((n - 1) / (2 ^ s)) % 2) do ( + s := s + 1 + ); + d := ((n - 1) / 2 ^ s); + for (i := 20, i > 0, i := i - 1) do ( + a := rand(n - 4) + 2; + x := powmod(a, d, n); + for (j := 0, j < s, j := j+1) do ( + y := powmod(x, 2, n); + if (y == 1 && (not x == 1) && (not x == n - 1)) then + result := 1; + else + skip; + x := y; + ); + if not y == 1 then result := 1; + else skip; + ) + ) +" +;; + +(* should return 0 because prime *) +Printf.printf "Miller-Rabin primality test program 1: "; +match get_result program 179424673 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; + +(* should return 1 because not prime *) +Printf.printf "Miller-Rabin primality test program 2: "; +match get_result program 179424675 with + Ok d -> Printf.printf "%d\n" d +| Error `AbsentAssignment msg -> Printf.printf "error -> %s\n" msg +| Error `DivisionByZero msg -> Printf.printf "error -> %s\n" msg +;; diff --git a/test/testingTypeFun.expected b/test/testingTypeFun.expected index e790c2c..37c44f4 100644 --- a/test/testingTypeFun.expected +++ b/test/testingTypeFun.expected @@ -1,6 +1,4 @@ Error absent assignment program: error (success) -Error wrong arity program 1: error (success) -Error wrong arity program 2: error (success) Error wrong return type program: error (success) Error wrong specification program: error (success) Error wrong input type program: error (success) diff --git a/test/testingTypeFun.ml b/test/testingTypeFun.ml index 4a2e40a..581d0e9 100644 --- a/test/testingTypeFun.ml +++ b/test/testingTypeFun.ml @@ -1,13 +1,13 @@ -open Lang.MiniTyFun -open Lang.MiniFunTypes +open MiniFun.TypeChecker +open MiniFun.Types (* -------------------------------------------------------------------------- *) (* Error absent assignment program *) let program = Function - (["a"], - FunctionType ([IntegerType], IntegerType), + ("a", + FunctionType (IntegerType, IntegerType), Variable "x" ) ;; @@ -16,42 +16,13 @@ match typecheck program with Error (`AbsentAssignment _) -> Printf.printf "Error absent assignment program: error (success)\n" | _ -> Printf.printf "Error absent assignment program: failed\n" -(* -------------------------------------------------------------------------- *) -(* Error wrong arity program *) - -let program = - Function - (["a"], - FunctionType ([IntegerType; IntegerType], IntegerType), - (Variable "a") - ) -;; - -match typecheck program with - Error (`WrongTypeSpecification _) -> Printf.printf "Error wrong arity program 1: error (success)\n" -| _ -> Printf.printf "Error wrong arity program 1: failed\n" - -let program = - LetFun - ("f", - ["a"; "b"], - FunctionType ([IntegerType; IntegerType], IntegerType), - (Variable "a"), - Function (["x"], FunctionType ([IntegerType], IntegerType), Application (Variable "f", [Integer 1; Integer 2; Variable "x"])) - ) -;; - -match typecheck program with - Error (`WrongArity _) -> Printf.printf "Error wrong arity program 2: error (success)\n" -| _ -> Printf.printf "Error wrong arity program 2: failed\n" - (* -------------------------------------------------------------------------- *) (* Error wrong return type program *) let program = Function - (["a"], - FunctionType ([IntegerType], BooleanType), + ("a", + FunctionType (IntegerType, BooleanType), (Variable "a") ) ;; @@ -65,7 +36,7 @@ match typecheck program with let program = Function - (["a"], + ("a", IntegerType, (Variable "a") ) @@ -81,11 +52,11 @@ match typecheck program with let program = Application ( Function - (["a"; "b"], - FunctionType ([IntegerType; IntegerType], IntegerType), - (Variable "a") + ("a", + FunctionType (IntegerType, FunctionType (IntegerType, IntegerType)), + Function ("b", FunctionType (IntegerType, IntegerType), Variable "a") ), - [Boolean false] + Boolean false ) ;; @@ -99,7 +70,7 @@ match typecheck program with let program = Application ( Integer 0, - [Boolean false] + Boolean false ) ;; @@ -112,8 +83,8 @@ match typecheck program with let program = Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), IfThenElse (Cmp (Integer 1, Integer 2), Boolean true, Integer 1) ) ;; @@ -127,8 +98,8 @@ match typecheck program with let program = Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), IfThenElse (Integer 1, Integer 2, Integer 1) ) ;; @@ -142,8 +113,8 @@ match typecheck program with (* Identity program *) let program = Function - (["a"], - FunctionType ([IntegerType], IntegerType), + ("a", + FunctionType (IntegerType, IntegerType), (Variable "a") ) ;; @@ -156,8 +127,8 @@ match typecheck program with (* Constant program *) let program = Function - (["a"], - FunctionType ([IntegerType], IntegerType), + ("a", + FunctionType (IntegerType, IntegerType), (Integer 1) ) ;; @@ -171,10 +142,15 @@ match typecheck program with let program = LetIn ("f", - (Function (["x"; "y"], - FunctionType ([IntegerType; IntegerType], IntegerType), - Plus (Variable "x", Variable "y"))), - (Application (Variable "f", [Integer 3])) + (Function ( + "x", + FunctionType (IntegerType, FunctionType (IntegerType, IntegerType)), + Function ("y", + FunctionType (IntegerType, IntegerType), + Plus (Variable "x", Variable "y") + ) + )), + (Application (Variable "f", Integer 3)) ) ;; @@ -187,12 +163,12 @@ match typecheck program with let program = LetFun ("f", - ["x"], - FunctionType ([IntegerType], FunctionType ([IntegerType], IntegerType)), - (Function (["y"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, FunctionType (IntegerType, IntegerType)), + (Function ("y", + FunctionType (IntegerType, IntegerType), Plus (Variable "x", Variable "y"))), - (Application (Variable "f", [Integer 3])) + (Application (Variable "f", Integer 3)) ) ;; @@ -206,18 +182,18 @@ let program = LetIn ("f", (Function ( - ["z"], - FunctionType ([FunctionType ([IntegerType], IntegerType)], FunctionType ([FunctionType ([IntegerType], IntegerType)], FunctionType ([IntegerType], IntegerType))), + "z", + FunctionType (FunctionType (IntegerType, IntegerType), FunctionType (FunctionType (IntegerType, IntegerType), FunctionType (IntegerType, IntegerType))), (Function ( - ["y"], - FunctionType ([FunctionType ([IntegerType], IntegerType)], FunctionType ([IntegerType], IntegerType)), + "y", + FunctionType (FunctionType (IntegerType, IntegerType), FunctionType (IntegerType, IntegerType)), Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), (IfThenElse ( CmpLess (Variable "x", Integer 0), - (Application (Variable "y", [Variable "x"])), - (Application (Variable "z", [Variable "x"])) + (Application (Variable "y", Variable "x")), + (Application (Variable "z", Variable "x")) ))) )) )), @@ -225,10 +201,10 @@ let program = ( (Application (Variable "f", - [Function (["x"], FunctionType ([IntegerType], IntegerType), Plus (Variable "x", Integer 1))] + Function ("x", FunctionType (IntegerType, IntegerType), Plus (Variable "x", Integer 1)) ) ), - [Function (["x"], FunctionType ([IntegerType], IntegerType), Minus (Variable "x", Integer 1))] + Function ("x", FunctionType (IntegerType, IntegerType), Minus (Variable "x", Integer 1)) ) ) ) @@ -243,9 +219,9 @@ match typecheck program with let program = LetFun ("f", - ["x"], - FunctionType ([IntegerType], IntegerType), - (IfThenElse (CmpLess (Variable "x", Integer 2),Integer 1, Plus (Variable "x", Application (Variable "f", [Minus (Variable "x", Integer 1)])))), + "x", + FunctionType (IntegerType, IntegerType), + (IfThenElse (CmpLess (Variable "x", Integer 2),Integer 1, Plus (Variable "x", Application (Variable "f", Minus (Variable "x", Integer 1))))), (Variable "f") ) ;; @@ -259,7 +235,7 @@ match typecheck program with let program = LetIn ("f", - (LetIn ("a", Integer 1, (Function (["y"], FunctionType ([IntegerType], IntegerType), Plus (Variable "y", Variable "a"))))), + (LetIn ("a", Integer 1, (Function ("y", FunctionType (IntegerType, IntegerType), Plus (Variable "y", Variable "a"))))), (LetIn ("a", Integer 2, Variable "f")) ) ;; @@ -273,9 +249,9 @@ match typecheck program with let program = LetFun ( "f", - ["x"], - FunctionType ([IntegerType], IntegerType), - (IfThenElse (CmpLessEq (Variable "x", Integer 0), Integer 1, Times (Variable "x", Application (Variable "f", [Minus (Variable "x", Integer 1)])))), + "x", + FunctionType (IntegerType, IntegerType), + (IfThenElse (CmpLessEq (Variable "x", Integer 0), Integer 1, Times (Variable "x", Application (Variable "f", Minus (Variable "x", Integer 1))))), (Variable "f") ) ;; @@ -290,18 +266,25 @@ match typecheck program with let program = LetFun ( "collatz", - ["n"; "count"], - FunctionType ([IntegerType; IntegerType], IntegerType), + "input", + FunctionType (TupleType (IntegerType, IntegerType), IntegerType), ( - IfThenElse (BNot (Cmp (Variable "n", Integer 1)), - (IfThenElse (Cmp (Modulo (Variable "n", Integer 2), Integer 0), - Application (Variable "collatz", [Division (Variable "n", Integer 2); Plus (Integer 1, Variable "count")]), - Application (Variable "collatz", [(Plus (Integer 1, Times (Integer 3, Variable "n"))); Plus (Integer 1, Variable "count")]))), - (Variable "count")) + IfThenElse (BNot (Cmp (First (Variable "input"), Integer 1)), + (IfThenElse (Cmp (Modulo (First (Variable "input"), Integer 2), Integer 0), + Application (Variable "collatz", + Tuple ( + Division (First (Variable "input"), Integer 2), + Plus (Integer 1, Second (Variable "input")))), + Application (Variable "collatz", + Tuple ( + Plus (Integer 1, Times (Integer 3, First (Variable "input"))), + Plus (Integer 1, Second (Variable "input")))))), + (Second (Variable "input"))) ), - (Function (["x"], - FunctionType ([IntegerType], IntegerType), - Application (Variable "collatz", [Variable "x"; Integer 1]))) + (Function ("x", + FunctionType (IntegerType, IntegerType), + Application (Variable "collatz", Tuple (Variable "x", Integer 1))) + ) ) ;; @@ -315,13 +298,13 @@ match typecheck program with let program = LetFun ( "sum", - ["n"], - FunctionType ([IntegerType], IntegerType), + "n", + FunctionType (IntegerType, IntegerType), (IfThenElse ((BOr (Cmp (Modulo (Variable "n", Integer 3), Integer 0), Cmp (Modulo (Variable "n", Integer 5), Integer 0))), - Plus (Variable "n", Application (Variable "sum", [Minus (Variable "n", Integer 1)])), + Plus (Variable "n", Application (Variable "sum", Minus (Variable "n", Integer 1))), (IfThenElse ((CmpLessEq (Variable "n", Integer 1)), (Integer 0), - (Application (Variable "sum", [Minus (Variable "n", Integer 1)]))) + (Application (Variable "sum", Minus (Variable "n", Integer 1)))) )) ), (Variable "sum") @@ -336,8 +319,8 @@ match typecheck program with (* Rand program *) let program = Function ( - ["x"], - FunctionType ([IntegerType], IntegerType), + "x", + FunctionType (IntegerType, IntegerType), Rand (Variable "x") ) @@ -352,19 +335,20 @@ match typecheck program with let program = LetFun ( "fib", - ["i"; "a"; "b"], - FunctionType ([IntegerType; IntegerType; IntegerType], IntegerType), - (IfThenElse (Cmp (Variable "i", Integer 0), - Variable "a", - Application (Variable "fib", [Minus (Variable "i", Integer 1); - Variable "b"; - Plus (Variable "a", Variable "b")]) + "input", + FunctionType (TupleType (TupleType (IntegerType, IntegerType), IntegerType), IntegerType), + (IfThenElse (Cmp (First (First (Variable "input")), Integer 0), + Second (First (Variable "input")), + Application (Variable "fib", + Tuple ( Tuple ( + Minus (First (First (Variable "input")), Integer 1), + Second (Variable "input")), + Plus (Second (First (Variable "input")), Second (Variable "input")))) )), - Function (["x"], - FunctionType ([IntegerType], IntegerType), - (Application (Variable "fib", [Variable "x"; Integer 0; Integer 1]))) + Function ("x", + FunctionType (IntegerType, IntegerType), + (Application (Variable "fib", Tuple (Tuple (Variable "x", Integer 0), Integer 1)))) ) - ;; match typecheck program with diff --git a/test/testingTypeFunParser.expected b/test/testingTypeFunParser.expected new file mode 100644 index 0000000..d427952 --- /dev/null +++ b/test/testingTypeFunParser.expected @@ -0,0 +1,20 @@ +Error absent assignment program: error (success) +Error wrong type program: error (success) +Error wrong return type program: error (success) +Error wrong specification program: error (success) +Error wrong input type program: error (success) +Error not a function program: error (success) +Error if branches with different types program: error (success) +Error if guard is not a boolean program: error (success) +Identity program: success +Constant program: success +Partial application of function program 1: success +Partial application of function program 2: success +Passing functions to functions program: success +Recursive function program: success +Scope program: success +Factorial program: success +Hailstone sequence's lenght program: success +Sum multiples of 3 and 5 program: success +Rand program: success +Fibonacci program: success diff --git a/test/testingTypeFunParser.ml b/test/testingTypeFunParser.ml new file mode 100644 index 0000000..dad6fc8 --- /dev/null +++ b/test/testingTypeFunParser.ml @@ -0,0 +1,251 @@ +open MiniFun + +let get_result x = + Lexing.from_string x |> Parser.prg Lexer.lex |> TypeChecker.typecheck + +(* -------------------------------------------------------------------------- *) +(* Error absent assignment program *) + +let program = + "lambda a: int -> int => x" +;; + +Printf.printf "Error absent assignment program: "; +match get_result program with + Error (`AbsentAssignment _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf "failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error wrong type program *) + +let program = + "lambda a: (int, int) -> int => a" +;; + +Printf.printf "Error wrong type program: "; +match get_result program with + Error (`WrongTypeSpecification _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error wrong return type program *) + +let program = + "lambda a: int -> bool => a" +;; + +Printf.printf "Error wrong return type program: "; +match get_result program with + Error (`WrongTypeSpecification _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error wrong specification program *) + +let program = + "lambda a: int => a" +;; + +Printf.printf "Error wrong specification program: "; +match get_result program with + Error (`WrongTypeSpecification _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error wrong input type program *) + +let program = + "(lambda a: int -> int => a) false" +;; + +Printf.printf "Error wrong input type program: "; +match get_result program with + Error (`WrongType _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error not a function program *) + +let program = + "0 false" +;; + +Printf.printf "Error not a function program: "; +match get_result program with + Error (`WrongType _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error if branches with different types program *) + +let program = + "lambda x: int -> int => if 1 == 2 then true else 1" +;; + +Printf.printf "Error if branches with different types program: "; +match get_result program with + Error (`WrongType _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Error if guard is not a boolean program *) + +let program = + "lambda x: int -> int => (if 1 then 2 else 1)" +;; + +Printf.printf "Error if guard is not a boolean program: "; +match get_result program with + Error (`WrongType _) -> Printf.printf "error (success)\n" +| _ -> Printf.printf " failed\n" + + +(* -------------------------------------------------------------------------- *) +(* Identity program *) +let program = + "lambda a: int -> int => a" +;; + +Printf.printf "Identity program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Constant program *) +let program = + "lambda a: int -> int => 1" +;; + +Printf.printf "Constant program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Partial application of function program *) +let program = + "let f = lambda x: int -> int -> int => lambda y: int -> int => x + y in f 3" +;; + +Printf.printf "Partial application of function program 1: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Partial application of function program *) +let program = + "let rec f x: int -> int -> int = lambda y: int -> int => x + y in f 3" +;; + +Printf.printf "Partial application of function program 2: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Passing functions to functions program *) +let program = + "let f = + \\z: (int -> int) -> (int -> int) -> int -> int => + \\y: (int -> int) -> int -> int => + \\x: int -> int => + if x < 0 then y x else z x + in (f (\\x: int -> int => x + 1)) (\\x: int -> int => x - 1)" +;; + +Printf.printf "Passing functions to functions program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Recursive function program *) +let program = + "let rec f x: int -> int = if x < 2 then 1 else x + f (x - 1) in f" +;; + +Printf.printf "Recursive function program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Scope program *) +let program = + "let f = let a = 1 in fun y: int -> int => y + a in let a = 2 in f" +;; + +Printf.printf "Scope program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Factorial program *) +let program = + "let rec f x: int -> int = if x <= 0 then 1 else x * f (x - 1) in f" +;; + +Printf.printf "Factorial program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Hailstone sequence's lenght program *) + +let program = + "let rec collatz input: (int, int) -> int = + if not (fst input == 1) then + if fst input % 2 == 0 then collatz ((fst input / 2), (snd input + 1)) + else collatz ((1 + fst input * 3), (snd input + 1)) + else snd input + in fun x: int -> int => collatz (x, 1) +" +;; + +Printf.printf "Hailstone sequence's lenght program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Sum multiples of 3 and 5 program *) + +let program = + "let rec sum n: int -> int = if n % 3 == 0 || n % 5 == 0 then n + sum (n - 1) else if n < 1 then 0 else sum (n - 1) in sum" +;; + +Printf.printf "Sum multiples of 3 and 5 program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Rand program *) +let program = + "fun x: int -> int => rand x" +;; + +Printf.printf "Rand program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n" + +(* -------------------------------------------------------------------------- *) +(* Fibonacci program *) +let program = + "let rec fib input: + int, int, int -> int = + if fst fst input == 0 + then snd fst input + else fib (((fst fst input - 1), snd input), (snd fst input + snd input)) + in lambda x: int -> int => fib ((x, 0), 1)" +;; + +Printf.printf "Fibonacci program: "; +match get_result program with + Ok _ -> Printf.printf "success\n" +| _ -> Printf.printf " failed\n"