diff --git a/LANGUAGE.md b/LANGUAGE.md index 4d67090..4fd7b3e 100644 --- a/LANGUAGE.md +++ b/LANGUAGE.md @@ -23,24 +23,31 @@ If you want to store some value, you need to use a argument. An argument have a addressing mode and a value. -- (mode var) mode can be specified (mode is optional) +- (none) replaced by immediate 0 +- (var) declare a argument using default mode +- (mode var) declare a argument using specified mode ### Variables (var) -Variables are numbers or texts used to store values. +Variables are numbers or strings used to store values. +By default, numbers use immediate mode and strings use direct mode. -- Number Immediate mode by default -- Text Direct mode by default +- (number) integer signed or unsigned number +- (string) string reference to let variable or label + +If the string corresponds to some variable in scope, the string will be replaced by a reference to this variable, otherwise the string will be kept referencing a label ### Addresing modes (mode) Addresing modes are used to specify how the argument is used in the instruction. If the addressing mode is not specified, the default mode is used. -- (Dir var) direct addresing to var -- (Ind var) indirect addresing to var -- (Dec var) decrement var and indirect addresing to var -- (Inc var) indirect addresing to var and increment var -- (store var) store var value in this place (field is automatic) +- (Imm var) | (# var) immediate addresing to var +- (Dir var) | ($ var) direct addresing to var +- (Ind var) | (@ var) indirect addresing to var +- (Dec var) | (< var) decrement var and indirect addresing to var +- (Inc var) | (> var) indirect addresing to var and increment var +- (instr var) | (% var) points to the instruction instead of the value +- (store var) | (! var) store var value in this place (field is automatic) ## Conditions (cond) @@ -53,6 +60,7 @@ Unary conditions are used to specify when the control flow is executed based on - (JZ x) x is zero - (JN x) x is not zero +- (DZ x) decrement x and x is zero - (DN x) decrement x and x is not zero ### Binary conditions (cond2) @@ -71,7 +79,10 @@ Instructions are used to specify the operation to be performed. Instruction modi ### redcode instructions -All redcode instructions are available for direct use +All redcode instructions are available for direct use. +Square brackets '[]' indicates that the argument is optional. + +- (NOP [arg1] [arg2]) no operation (arg1 & arg2 only store data) - (DAT arg1 arg2) data values - (MOV arg1 arg2) move arg1 to arg2 @@ -82,12 +93,8 @@ All redcode instructions are available for direct use - (DIV arg1 arg2) div arg1 from arg2 - (MOD arg1 arg2) mod arg1 from arg2 -- (JMP arg1 [arg2]) jump to arg1 (arg2 is optional) -- (SPL arg1 [arg2]) split to arg1 (arg2 is optional) - -- (NOP) no operation - -Not added yet +- (JMP arg1 [arg2]) jump to arg1 (arg2 only store data) +- (SPL arg1 [arg2]) split to arg1 (arg2 only store data) - (JMZ arg1 arg2) jump to arg1 if arg2 is zero - (JMN arg1 arg2) jump to arg1 if arg2 is not zero diff --git a/README.md b/README.md index 839e53a..1395448 100644 --- a/README.md +++ b/README.md @@ -15,8 +15,9 @@ work in progress. To execute the resulting redcode you can use one of these redcode interpreters. +- [pMARS](https://corewar.co.uk/pmars.htm) - [A.R.E.S.](https://corewar.co.uk/ares.htm) -- [PyMARS](https://github.com/rodrigosetti/corewar) +- [python MARS](https://github.com/rodrigosetti/corewar) #### TODO diff --git a/bbctests/examples/prog0.bbc b/bbctests/examples/prog0.bbc index acc74fa..26f0c9d 100644 --- a/bbctests/examples/prog0.bbc +++ b/bbctests/examples/prog0.bbc @@ -1,9 +1,9 @@ NAME: test imp DESCRIPTION: evaluates a function declaration SRC: -(MOV 0 1) +(MOV (Dir 0) (Dir 1)) EXPECTED: ;redcode-94b - MOV.I #0 , #1 + MOV.I $0 , $1 DAT #0 , #0 \ No newline at end of file diff --git a/bbctests/examples/prog1.bbc b/bbctests/examples/prog1.bbc index 27cabef..3dd931d 100644 --- a/bbctests/examples/prog1.bbc +++ b/bbctests/examples/prog1.bbc @@ -3,8 +3,8 @@ DESCRIPTION: evaluates a function declaration SRC: (let (x dest) (seq - (MOV (Dir -1) (store x)) - (ADD 4 x) + (MOV (Ins -1) (store x)) + (ADD 4 x) (JMP x) (label dest) )) EXPECTED: diff --git a/bbctests/examples/prog10.bbc b/bbctests/examples/prog10.bbc new file mode 100644 index 0000000..946890e --- /dev/null +++ b/bbctests/examples/prog10.bbc @@ -0,0 +1,18 @@ +NAME: long labels +DESCRIPTION: evaluates a function declaration +SRC: +(let (x dest_with_some_extra_characters) + (seq + (MOV (Ins -1) (store x)) + (ADD 4 x) + (JMP x) + (label dest_with_some_extra_characters) )) +EXPECTED: +;redcode-94b + +LET1 + MOV.I $-1 , $dest_with_some_extra_characters + ADD.AB #4 , $LET1 + JMP $LET1 , #0 +dest_with_some_extra_characters + DAT #0 , #0 \ No newline at end of file diff --git a/bbctests/examples/prog4.bbc b/bbctests/examples/prog4.bbc index 0589950..1ecec30 100644 --- a/bbctests/examples/prog4.bbc +++ b/bbctests/examples/prog4.bbc @@ -15,7 +15,7 @@ SRC: (label dest4) (JMP (Ind c)) (label dest1) - (MOV (Dir 0) (Dir 1)) ))))) + (MOV (Ins 0) (Dir 1)) ))))) EXPECTED: ;redcode-94b diff --git a/bbctests/examples/prog6.bbc b/bbctests/examples/prog6.bbc index d115b52..a2b80bf 100644 --- a/bbctests/examples/prog6.bbc +++ b/bbctests/examples/prog6.bbc @@ -4,7 +4,7 @@ SRC: (let (x (Dir 3)) (repeat (seq - (MOV (Dir -1) (store x)) + (MOV (Ins -1) (store x)) (ADD 1 x) ))) EXPECTED: ;redcode-94b diff --git a/bbctests/examples/prog7.bbc b/bbctests/examples/prog7.bbc index a47bcda..d38be72 100644 --- a/bbctests/examples/prog7.bbc +++ b/bbctests/examples/prog7.bbc @@ -6,7 +6,7 @@ SRC: (JMP (Dir 2)) (DAT 0 (store x)) (do-while (DN 100) - (MOV (Dir -1) (Inc x)) ))) + (MOV (Ins -1) (Inc x)) ))) EXPECTED: ;redcode-94b diff --git a/bbctests/examples/prog8.bbc b/bbctests/examples/prog8.bbc index 1669d20..313a1c2 100644 --- a/bbctests/examples/prog8.bbc +++ b/bbctests/examples/prog8.bbc @@ -8,7 +8,7 @@ SRC: (DAT (store x) (store y)) (while (LT y x) (seq - (MOV x (Dec x)) ))))) + (MOV (Ins x) (Dec x)) ))))) EXPECTED: ;redcode-94b @@ -19,7 +19,7 @@ LET2 WHI9 SLT.BA $LET2 , $LET1 JMP $WHF9 , #0 - MOV.A $LET1 , {LET1 + MOV.I $LET1 , {LET1 JMP $WHI9 , #0 WHF9 DAT #0 , #0 \ No newline at end of file diff --git a/dev/analyse.ml b/dev/analyse.ml index 0b25047..05051c1 100644 --- a/dev/analyse.ml +++ b/dev/analyse.ml @@ -2,9 +2,6 @@ open String open Ast open Lib -open Verify - -exception CTError of string let analyse_store_arg (arg : arg) (id : string) (place : place) (penv : penv) : penv = @@ -12,7 +9,7 @@ let analyse_store_arg (arg : arg) (id : string) (place : place) (penv : penv) : | AStore (s) -> (match (equal id s) with | true -> (extend_penv s place penv) - | _ -> penv) + | false -> penv) | _ -> penv let analyse_store_cond (cond : cond) (id : string) (penv : penv) : penv = @@ -24,22 +21,25 @@ let analyse_store_cond (cond : cond) (id : string) (penv : penv) : penv = let rec analyse_store_expr (e : tag eexpr) (id : string) (penv : penv) : penv = match e with + | ELabel (_) -> penv | EPrim2 (_, a1, a2, _) -> let env' = (analyse_store_arg a1 id PA penv) in (analyse_store_arg a2 id PB env') - | ELet (_, _, e, _) -> - (analyse_store_expr e id penv) - | ECont1 (_, cond, expr, _) -> + | EFlow (_, exp, _) -> (analyse_store_expr exp id penv) + | EFlow1 (_, cond, exp, _) -> let env' = (analyse_store_cond cond id penv) in - (analyse_store_expr expr id env') - | ERepeat (e, _) -> (analyse_store_expr e id penv) - | ESeq (exprs, _) -> List.fold_left (fun penv' e -> (analyse_store_expr e id penv')) penv exprs - | _ -> penv + (analyse_store_expr exp id env') + | EFlow2 (_, cond, exp1, exp2, _) -> + let penv' = (analyse_store_cond cond id penv) in + let penv'' = (analyse_store_expr exp1 id penv') in + (analyse_store_expr exp2 id penv'') + | ELet (_, _, exp, _) -> (analyse_store_expr exp id penv) + | ESeq (exps, _) -> List.fold_left (fun penv' exp -> (analyse_store_expr exp id penv')) penv exps + let analyse_let (id : string) (arg : arg) (body : tag eexpr) (label : string) (env : env) : env = - let _ = (verify_let arg) in let aenv, penv, lenv = env in let aenv' = (extend_aenv id arg aenv) in let penv' = (analyse_store_expr body id penv) in let lenv' = (extend_lenv id label lenv) in - (aenv', penv', lenv') \ No newline at end of file + (aenv', penv', lenv') diff --git a/dev/ast.ml b/dev/ast.ml index aa9836f..37a9bcd 100644 --- a/dev/ast.ml +++ b/dev/ast.ml @@ -6,11 +6,16 @@ type place = | PB +type imode = +| MINone +| MIInc +| MIDec + type mode = -| MDir -| MInd -| MDec -| MInc +| MIns (* Instruction *) +| MImm (* Immediate *) +| MDir (* Direct *) +| MInd of imode (* Indirect *) type arg = | ANone @@ -24,6 +29,7 @@ type arg = type cond1 = | Cjz | Cjn +| Cdz | Cdn type cond2 = @@ -47,55 +53,69 @@ type prim2 = | Mod | Jmp | Spl +| Nop + +| Jmz +| Jmn +| Djn +| Seq +| Sne +| Slt -type cont1 = +type flow = +| Repeat + +type flow1 = | If | While -| Dowhile +| DoWhile + +type flow2 = +| IfElse type expr = -| Nop | Label of string | Prim2 of prim2 * arg * arg -| Cont1 of cont1 * cond * expr +| Flow of flow * expr +| Flow1 of flow1 * cond * expr +| Flow2 of flow2 * cond * expr * expr | Let of string * arg * expr -| Repeat of expr | Seq of expr list type 'a eexpr = -| ENop of 'a | ELabel of string * 'a | EPrim2 of prim2 * arg * arg * 'a -| ECont1 of cont1 * cond * 'a eexpr * 'a +| EFlow of flow * 'a eexpr * 'a +| EFlow1 of flow1 * cond * 'a eexpr * 'a +| EFlow2 of flow2 * cond * 'a eexpr * 'a eexpr * 'a | ELet of string * arg * 'a eexpr * 'a -| ERepeat of 'a eexpr * 'a | ESeq of 'a eexpr list * 'a type tag = int - let rec tag_expr_help (e : expr) (cur : tag) : (tag eexpr * tag) = match e with - | Nop -> - let (next_tag) = (cur + 1) in - (ENop (cur), next_tag) | Label (s) -> let (next_tag) = (cur + 1) in (ELabel (s, cur), next_tag) | Prim2 (op, a1, a2) -> let (next_tag) = (cur + 1) in (EPrim2 (op, a1, a2, cur), next_tag) - | Cont1 (op, c, expr) -> + | Flow (op, expr) -> let (tag_expr, next_tag) = tag_expr_help expr (cur + 1) in - (ECont1 (op, c, tag_expr, cur), next_tag) + (EFlow (op, tag_expr, cur), next_tag) + | Flow1 (op, cond, expr) -> + let (tag_expr, next_tag) = tag_expr_help expr (cur + 1) in + (EFlow1 (op, cond, tag_expr, cur), next_tag) + | Flow2 (op, cond, expr1, expr2) -> + let (tag_expr1, next_tag1) = tag_expr_help expr1 (cur + 1) in + let (tag_expr2, next_tag2) = tag_expr_help expr2 next_tag1 in + (EFlow2 (op, cond, tag_expr1, tag_expr2, cur), next_tag2) | Let (x, a, expr) -> let (tag_expr, next_tag) = tag_expr_help expr (cur + 1) in (ELet (x, a, tag_expr, cur), next_tag) - | Repeat (expr) -> - let (tag_expr, next_tag) = tag_expr_help expr (cur + 1) in - (ERepeat (tag_expr, cur), next_tag) | Seq (exprs) -> let rec tag_seq (exprs : expr list) (cur : tag) : tag eexpr list * tag = (match exprs with diff --git a/dev/compile.ml b/dev/compile.ml index 673b92d..d2e0028 100644 --- a/dev/compile.ml +++ b/dev/compile.ml @@ -3,127 +3,134 @@ open Printf open Red open Ast open Lib +open Util open Analyse exception CTError of string -let rec compile_arg (arg : arg) (env : env) : rarg = - let aenv, penv, lenv = env in - match arg with - | ANone -> RNone - | ANum (n) -> RNum (n) - | AId (s) -> - (match List.assoc_opt s lenv with - | Some l -> RLab ((compile_mode MDir PB), l) - | None -> RLab ((compile_mode MDir PB), s) ) - | ARef (m, n) -> RRef ((compile_mode m PB), n) - | ALab (m, s) -> - (match List.assoc_opt s lenv with - | Some arg -> - let dest = (translate_penv s penv) in - RLab ((compile_mode m dest), arg) - | None -> RLab ((compile_mode m PB), s) ) - | AStore (s) -> - let arg = (translate_aenv s aenv) in - (match arg with - | AId (s) -> - (match List.assoc_opt s lenv with - | Some label -> RLab ((compile_mode MDir PB), label) - | None -> (compile_arg arg env) ) - | ALab (m, s) -> - (match List.assoc_opt s lenv with - | Some label -> - let dest = (translate_penv s penv) in - RLab ((compile_mode m dest), label) - | None -> (compile_arg arg env) ) - | _ -> (compile_arg arg env) ) - let compile_label (args : arg list) (env : env) : instruction list = - let compile_label_aux (arg : arg) (env: env) : instruction list = + let compile_label_aux (arg : arg) (env : env) : instruction list = match arg with | AStore (s) -> let _, _, lenv = env in (match List.assoc_opt s lenv with | Some l -> [ILabel (l)] - | None -> failwith (sprintf "unbound variable %s in lenv" s) ) + | None -> raise (CTError (sprintf "unbound variable %s in lenv" s)) ) | _ -> [] in List.fold_left (fun res i -> res @ (compile_label_aux i env)) [] args let compile_precond (cond : cond) (label : string ) (env : env) : instruction list = match cond with - | Cond1 (op, e) -> + | Cond1 (op, a) -> + let _, rarg = (compile_arg a env) in + let rmod = RB in (match op with - | Cjz -> [IJMN (RB, RLab(RDir, label), (compile_arg e env))] - | Cjn -> [IJMZ (RB, RLab(RDir, label), (compile_arg e env))] + | Cjz -> [IJMN (rmod, RLab (RDir, label), rarg)] + | Cjn -> [IJMZ (rmod, RLab (RDir, label), rarg)] + | Cdz -> [IDJN (rmod, RLab (RDir, label), rarg)] | Cdn -> raise (CTError (sprintf "DN cond is not available on precondition")) ) - | Cond2 (op, e1, e2) -> + | Cond2 (op, a1, a2) -> + let carg1, rarg1 = (compile_arg a1 env) in + let carg2, rarg2 = (compile_arg a2 env) in + let rmod = (compile_mod carg1 carg2 RI env) in (match op with - | Ceq -> [ISEQ ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] - | Cne -> [ISNE ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] - | Cgt -> [ISLT ((compile_mod e2 e1 env), (compile_arg e2 env), (compile_arg e1 env)) ; IJMP (RLab(RDir, label), RNone)] - | Clt -> [ISLT ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] ) + | Ceq -> [ISEQ (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] + | Cne -> [ISNE (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] + | Cgt -> + let rmod' = (compile_mod carg2 carg1 RI env) in + [ISLT (rmod', rarg2, rarg1) ; IJMP (RLab (RDir, label), RNone)] + | Clt -> [ISLT (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] ) let compile_postcond (cond : cond) (label : string ) (env : env) : instruction list = match cond with - | Cond1 (op, e) -> + | Cond1 (op, a) -> + let _, rarg = (compile_arg a env) in + let rmod = RB in (match op with - | Cjz -> [IJMZ (RB, RLab(RDir, label), (compile_arg e env))] - | Cjn -> [IJMN (RB, RLab(RDir, label), (compile_arg e env))] - | Cdn -> [IDJN (RB, RLab(RDir, label), (compile_arg e env))] ) - | Cond2 (op, e1, e2) -> + | Cjz -> [IJMZ (rmod, RLab (RDir, label), rarg)] + | Cjn -> [IJMN (rmod, RLab (RDir, label), rarg)] + | Cdz -> raise (CTError (sprintf "DZ cond is not available on postcondition")) + | Cdn -> [IDJN (rmod, RLab (RDir, label), rarg)] ) + | Cond2 (op, a1, a2) -> + let carg1, rarg1 = (compile_arg a1 env) in + let carg2, rarg2 = (compile_arg a2 env) in + let rmod = (compile_mod carg1 carg2 RI env) in (match op with - | Ceq -> [ISNE ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] - | Cne -> [ISEQ ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] - | Cgt -> [ISLT ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env)) ; IJMP (RLab(RDir, label), RNone)] - | Clt -> [ISLT ((compile_mod e2 e1 env), (compile_arg e2 env), (compile_arg e1 env)) ; IJMP (RLab(RDir, label), RNone)] ) + | Ceq -> [ISNE (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] + | Cne -> [ISEQ (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] + | Cgt -> [ISLT (rmod, rarg1, rarg2) ; IJMP (RLab (RDir, label), RNone)] + | Clt -> + let rmod' = (compile_mod carg2 carg1 RI env) in + [ISLT (rmod', rarg2, rarg1) ; IJMP (RLab (RDir, label), RNone)] ) let rec compile_expr (e : tag eexpr) (env : env) : instruction list = match e with - | ENop (_) -> [INOP] | ELabel (l, _) -> [ILabel (l)] - | EPrim2 (op, e1, e2, _) -> - (compile_label [e1; e2] env) @ + | EPrim2 (op, arg1, arg2, _) -> + let carg1, rarg1 = (compile_arg arg1 env) in + let carg2, rarg2 = (compile_arg arg2 env) in + let rmod = (compile_mod carg1 carg2 RI env) in + (compile_label [arg1; arg2] env) @ (match op with - | Dat -> [IDAT ((compile_arg e1 env), (compile_arg e2 env))] - | Mov -> [IMOV ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Add -> [IADD ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Sub -> [ISUB ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Mul -> [IMUL ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Div -> [IDIV ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Mod -> [IMOD ((compile_mod e1 e2 env), (compile_arg e1 env), (compile_arg e2 env))] - | Spl -> [ISPL ((compile_arg e1 env), (compile_arg e2 env))] - | Jmp -> [IJMP ((compile_arg e1 env), (compile_arg e2 env))] ) - | ECont1 (op, c, e, tag) -> + | Dat -> [IDAT (rarg1, rarg2)] + | Mov -> [IMOV (rmod, rarg1, rarg2)] + | Add -> [IADD (rmod, rarg1, rarg2)] + | Sub -> [ISUB (rmod, rarg1, rarg2)] + | Mul -> [IMUL (rmod, rarg1, rarg2)] + | Div -> [IDIV (rmod, rarg1, rarg2)] + | Mod -> [IMOD (rmod, rarg1, rarg2)] + | Spl -> [ISPL (rarg1, rarg2)] + | Jmp -> [IJMP (rarg1, rarg2)] + | Nop -> [INOP (rarg1, rarg2)] + | Jmz -> [IJMZ (rmod, rarg1, rarg2)] + | Jmn -> [IJMN (rmod, rarg1, rarg2)] + | Djn -> [IDJN (rmod, rarg1, rarg2)] + | Seq -> [ISEQ (rmod, rarg1, rarg2)] + | Sne -> [ISNE (rmod, rarg1, rarg2)] + | Slt -> [ISLT (rmod, rarg1, rarg2)]) + | EFlow (op, exp, tag) -> + (match op with + | Repeat -> + let ini = (sprintf "REP%d" tag) in + [ILabel (ini)] @ (compile_expr exp env) @ [IJMP (RLab (RDir, ini), RNone)] ) + | EFlow1 (op, cond, exp, tag) -> (match op with | If -> let fin = (sprintf "IF%d" tag) in - (compile_precond c fin env) @ (compile_expr e env) @ [ILabel (fin)] + (compile_precond cond fin env) @ (compile_expr exp env) @ [ILabel (fin)] | While -> let ini = (sprintf "WHI%d" tag) in let fin = (sprintf "WHF%d" tag) in - [ILabel (ini)] @ (compile_precond c fin env) @ (compile_expr e env) @ [IJMP (RLab(RDir, ini), RNone)] @ [ILabel (fin)] - | Dowhile -> + [ILabel (ini)] @ (compile_precond cond fin env) @ (compile_expr exp env) @ + [IJMP (RLab(RDir, ini), RNone)] @ [ILabel (fin)] + | DoWhile -> let ini = (sprintf "DWH%d" tag) in - [ILabel (ini)] @ (compile_expr e env) @ (compile_postcond c ini env) ) + [ILabel (ini)] @ (compile_expr exp env) @ (compile_postcond cond ini env) ) + | EFlow2 (op, cond, exp1, exp2, tag) -> + (match op with + | IfElse -> + let mid = (sprintf "IFM%d" tag) in + let fin = (sprintf "IFF%d" tag) in + (compile_precond cond mid env) @ (compile_expr exp1 env) @ [IJMP (RLab (RDir, fin), RNone)] @ + [ILabel (mid)] @ (compile_expr exp2 env) @ [ILabel (fin)] ) | ELet (id, arg, body, tag) -> let label = (sprintf "LET%d" tag) in let env' = (analyse_let id arg body label env) in (compile_expr body env') - | ERepeat (e, tag) -> - let ini = (sprintf "REP%d" tag) in - [ILabel (ini)] @ (compile_expr e env) @ [IJMP (RLab(RDir, ini), RNone)] - | ESeq (exprs, _) -> - List.fold_left (fun res e -> res @ (compile_expr e env)) [] exprs + | ESeq (exps, _) -> + List.fold_left (fun res exp -> res @ (compile_expr exp env)) [] exps -let prelude = sprintf " +let prelude = " ;redcode-94b " +let epilogue = [IDAT (RRef (RImm, 0), RRef (RImm, 0))] + let compile_prog (e : expr) : string = - let tagged = (tag_expr e) in - let instrs = (compile_expr tagged empty_env) @ [IDAT (RNum 0, RNum 0)] in - (prelude) ^ (pp_instrs instrs) + let tag_e = (tag_expr e) in + let instrs = (compile_expr tag_e empty_env) in + (prelude) ^ (pp_instrs instrs) ^ (pp_instrs epilogue) diff --git a/dev/dune b/dev/dune index 6f3990a..d48874c 100644 --- a/dev/dune +++ b/dev/dune @@ -1,4 +1,4 @@ (library (name dev) - (modules red ast analyse verify compile lib util parse) + (modules red ast analyse compile lib util parse) (libraries containers)) diff --git a/dev/lib.ml b/dev/lib.ml index e43a056..6d0c67e 100644 --- a/dev/lib.ml +++ b/dev/lib.ml @@ -1,15 +1,15 @@ (* Lib *) open Printf -open Red open Ast +exception CTError of string + type aenv = (string * arg) list type penv = (string * place) list type lenv = (string * string) list type env = aenv * penv * lenv - let empty_env : env = ([], [], []) @@ -24,86 +24,16 @@ let extend_lenv (x : string) (label : string) (lenv : lenv) : lenv = let translate_aenv (x : string) (aenv : aenv) : arg = - (match List.assoc_opt x aenv with + match List.assoc_opt x aenv with | Some arg -> arg - | None -> failwith (sprintf "unbound variable %s in aenv" x) ) + | None -> raise (CTError (sprintf "unbound variable %s in aenv" x)) let translate_penv (x : string) (penv : penv) : place = - (match List.assoc_opt x penv with + match List.assoc_opt x penv with | Some place -> place - | None -> failwith (sprintf "unbound variable %s in penv" x) ) + | None -> raise (CTError (sprintf "unbound variable %s in penv" x)) let translate_lenv (x : string) (lenv : lenv) : string = - (match List.assoc_opt x lenv with + match List.assoc_opt x lenv with | Some label -> label - | None -> failwith (sprintf "unbound variable %s in lenv" x) ) - - -let compile_mode (mode : mode) (dest : place) : rmode = - match dest with - | PA -> - (match mode with - | MDir -> RDir - | MInd -> RAInd - | MDec -> RAPre - | MInc -> RAPos ) - | PB -> - (match mode with - | MDir -> RDir - | MInd -> RBInd - | MDec -> RBPre - | MInc -> RBPos ) - - -type opmod = -| TNum -| TRef -| TA -| TB - -let rec compile_opmod (arg : arg) (env : env) : opmod = - let aenv, penv, _ = env in - match arg with - | ANone -> TNum - | ANum _ -> TNum - | ARef (_, _) -> TRef - | AId s | ALab (_, s) -> - (match List.assoc_opt s aenv with - | Some arg -> - (match arg with - | AId (x) | ALab (_, x) -> - (match List.assoc_opt x penv with - | Some store -> - (match store with - | PA -> TA - | PB -> TB ) - | None -> - let store = (translate_penv s penv) in - (match store with - | PA -> TA - | PB -> TB )) - | _ -> - let store = (translate_penv s penv) in - (match store with - | PA -> TA - | PB -> TB )) - | None -> TRef ) - | AStore (s) -> - let arg = (translate_aenv s aenv) in - (compile_opmod arg env) - - -let compile_mod (arg1 : arg) (arg2 : arg) (env : env) : rmod = - let mod1 = (compile_opmod arg1 env) in - let mod2 = (compile_opmod arg2 env) in - match mod1, mod2 with - | TNum, TNum -> RI - | TNum, TA -> RA - | TNum, TB -> RAB - | TA, TNum -> RAB - | TA, TA -> RA - | TA, TB -> RAB - | TB, TNum -> RB - | TB, TA -> RBA - | TB, TB -> RB - | _, _ -> RI + | None -> raise (CTError (sprintf "unbound variable %s in lenv" x)) diff --git a/dev/parse.ml b/dev/parse.ml index 0fb1a87..8aa2742 100644 --- a/dev/parse.ml +++ b/dev/parse.ml @@ -8,16 +8,18 @@ exception CTError of string let parse_mode (sexp : sexp) : mode = match sexp with - | `Atom "Dir" -> MDir - | `Atom "Ind" -> MInd - | `Atom "Dec" -> MDec - | `Atom "Inc" -> MInc + | `Atom "Ins" | `Atom "%" -> MIns + | `Atom "Imm" | `Atom "#" -> MImm + | `Atom "Dir" | `Atom "$" -> MDir + | `Atom "Ind" | `Atom "@" -> MInd (MINone) + | `Atom "Dec" | `Atom "<" -> MInd (MIDec) + | `Atom "Inc" | `Atom ">" -> MInd (MIInc) | _ -> raise (CTError (sprintf "Not a valid mode: %s" (to_string sexp))) let parse_arg (sexp : sexp) : arg = match sexp with - | `Atom "None" -> ANone - | `List [`Atom "store"; `Atom s] -> AStore (s) + | `Atom "none" -> ANone + | `List [`Atom "store"; `Atom s] | `List [`Atom "!"; `Atom s] -> AStore (s) | `Atom s -> (match Int64.of_string_opt s with | Some n -> ANum (Int64.to_int n) @@ -28,10 +30,12 @@ let parse_arg (sexp : sexp) : arg = | None -> ALab ((parse_mode m), s) ) | _ -> raise (CTError (sprintf "Not a valid arg: %s" (to_string sexp))) + let parse_cond (sexp : sexp) : cond = match sexp with | `List [`Atom "JZ"; e] -> Cond1 (Cjz, parse_arg e) | `List [`Atom "JN"; e] -> Cond1 (Cjn, parse_arg e) + | `List [`Atom "DZ"; e] -> Cond1 (Cdz, parse_arg e) | `List [`Atom "DN"; e] -> Cond1 (Cdn, parse_arg e) | `List [`Atom "EQ"; e1 ; e2] -> Cond2 (Ceq, parse_arg e1, parse_arg e2) | `List [`Atom "NE"; e1 ; e2] -> Cond2 (Cne, parse_arg e1, parse_arg e2) @@ -39,23 +43,24 @@ let parse_cond (sexp : sexp) : cond = | `List [`Atom "LT"; e1 ; e2] -> Cond2 (Clt, parse_arg e1, parse_arg e2) | _ -> raise (CTError (sprintf "Not a valid cond: %s" (to_string sexp))) + let rec parse_exp (sexp : sexp) : expr = match sexp with - | `List [`Atom "NOP"] -> Nop | `List [`Atom "label"; `Atom s] -> Label (s) | `List (`Atom "seq" :: exps) -> Seq (List.map parse_exp exps) + | `List [eop] -> + (match eop with + | `Atom "NOP" -> Prim2 (Nop, ANone, ANone) + | _ -> raise (CTError (sprintf "Not a valid expr: %s" (to_string sexp))) ) | `List [eop; e] -> (match eop with | `Atom "JMP" -> Prim2 (Jmp, parse_arg e, ANone) | `Atom "SPL" -> Prim2 (Spl, parse_arg e, ANone) - | `Atom "repeat" -> Repeat (parse_exp e) - | _ -> raise (CTError (sprintf "Not a valid expr: %s" (to_string sexp))) ) + | `Atom "NOP" -> Prim2 (Nop, parse_arg e, ANone) + | `Atom "repeat" -> Flow (Repeat, parse_exp e) + | _ -> raise (CTError (sprintf "Not a valid unary expr: %s" (to_string sexp))) ) | `List [eop; e1; e2] -> (match eop with - | `Atom "let" -> - (match e1 with - | `List [`Atom id; e] -> Let (id, parse_arg e, parse_exp e2) - | _ -> raise (CTError (sprintf "Not a valid let assignment: %s" (to_string e1))) ) | `Atom "DAT" -> Prim2 (Dat, parse_arg e1, parse_arg e2) | `Atom "MOV" -> Prim2 (Mov, parse_arg e1, parse_arg e2) | `Atom "ADD" -> Prim2 (Add, parse_arg e1, parse_arg e2) @@ -65,10 +70,19 @@ let rec parse_exp (sexp : sexp) : expr = | `Atom "MOD" -> Prim2 (Mod, parse_arg e1, parse_arg e2) | `Atom "JMP" -> Prim2 (Jmp, parse_arg e1, parse_arg e2) | `Atom "SPL" -> Prim2 (Spl, parse_arg e1, parse_arg e2) - | `Atom "if" -> Cont1 (If, parse_cond e1, parse_exp e2) - | `Atom "while" -> Cont1 (While, parse_cond e1, parse_exp e2) - | `Atom "do-while" -> Cont1 (Dowhile, parse_cond e1, parse_exp e2) - | _ -> raise (CTError (sprintf "Not a valid expr: %s" (to_string sexp))) ) + | `Atom "NOP" -> Prim2 (Nop, parse_arg e1, parse_arg e2) + | `Atom "if" -> Flow1 (If, parse_cond e1, parse_exp e2) + | `Atom "while" -> Flow1 (While, parse_cond e1, parse_exp e2) + | `Atom "do-while" -> Flow1 (DoWhile, parse_cond e1, parse_exp e2) + | `Atom "let" -> + (match e1 with + | `List [`Atom id; e] -> Let (id, parse_arg e, parse_exp e2) + | _ -> raise (CTError (sprintf "Not a valid let assignment: %s" (to_string e1))) ) + | _ -> raise (CTError (sprintf "Not a valid binary expr: %s" (to_string sexp))) ) + | `List [eop; e1; e2; e3] -> + (match eop with + | `Atom "if" -> Flow2 (IfElse, parse_cond e1, parse_exp e2, parse_exp e3) + | _ -> raise (CTError (sprintf "Not a valid ternary expr: %s" (to_string sexp))) ) | _ -> raise (CTError (sprintf "Not a valid expr: %s" (to_string sexp))) diff --git a/dev/red.ml b/dev/red.ml new file mode 100644 index 0000000..cfd0fa2 --- /dev/null +++ b/dev/red.ml @@ -0,0 +1,115 @@ +(** RED **) +open Printf + + +(* addressing modes *) +type rmode = +| RImm (* immediate *) +| RDir (* direct *) +| RAInd (* A-field indirect *) +| RBInd (* B-field indirect *) +| RADec (* A-field indirect with predecrement *) +| RBDec (* B-field indirect with predecrement *) +| RAInc (* A-field indirect with postincrement *) +| RBInc (* B-field indirect with postincrement *) + +(* addressing modes to string *) +let pp_mode (rmode : rmode) : string = + match rmode with + | RImm -> "#" + | RDir -> "$" + | RAInd -> "*" + | RBInd -> "@" + | RADec -> "{" + | RBDec -> "<" + | RAInc -> "}" + | RBInc -> ">" + + +(* red arguments for opcodes *) +type rarg = +| RNone (* none arg *) +| RRef of rmode * int (* number arg *) +| RLab of rmode * string (* string arg *) + +(* rarguments for instruction to string *) +let pp_rarg (rarg : rarg) : string = + match rarg with + | RNone -> sprintf "#%-6s" (Int.to_string 0) + | RRef (m, n) -> sprintf "%s%-6s" (pp_mode m) (Int.to_string n) + | RLab (m, l) -> sprintf "%s%-6s" (pp_mode m) (l) + + +(* instruction modifiers *) +type rmod = +| RA (* A to A *) +| RB (* B to B *) +| RAB (* A to B *) +| RBA (* B to A *) +| RF (* AB to AB *) +| RX (* AB to BA *) +| RI (* instr to instr *) + +(* instruction modifiers to string *) +let pp_rmod (rmod : rmod) : string = + match rmod with + | RA -> ".A " + | RB -> ".B " + | RAB -> ".AB" + | RBA -> ".BA" + | RF -> ".F " + | RX -> ".X " + | RI -> ".I " + + +(* red opcode *) +type instruction = +| ILabel of string +| IDAT of rarg * rarg (* data *) +| IMOV of rmod * rarg * rarg (* move *) +| IADD of rmod * rarg * rarg (* add *) +| ISUB of rmod * rarg * rarg (* subtract *) +| IMUL of rmod * rarg * rarg (* multiply *) +| IDIV of rmod * rarg * rarg (* divide *) +| IMOD of rmod * rarg * rarg (* modulus *) +| ISPL of rarg * rarg (* split *) +| IJMP of rarg * rarg (* jump *) +| IJMZ of rmod * rarg * rarg (* jump if zero *) +| IJMN of rmod * rarg * rarg (* jump if not zero *) +| IDJN of rmod * rarg * rarg (* decrement and jump if not zero *) +| ICMP of rmod * rarg * rarg (* skip if equal *) +| ISEQ of rmod * rarg * rarg (* skip if equal *) +| ISNE of rmod * rarg * rarg (* skip if not equal *) +| ISLT of rmod * rarg * rarg (* skip if lower than *) +| ILDP of rmod * rarg * rarg (* load from p-space *) +| ISTP of rmod * rarg * rarg (* save to p-space *) +| INOP of rarg * rarg (* no operation *) + +(* red opcode to string *) +let pp_instr (opcode : instruction) : string = + match opcode with + | ILabel (l) -> sprintf "%-6s" (l) + | IDAT (e1, e2) -> sprintf " DAT %s, %s" (pp_rarg e1) (pp_rarg e2) + | IMOV (m, e1, e2) -> sprintf " MOV%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IADD (m, e1, e2) -> sprintf " ADD%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISUB (m, e1, e2) -> sprintf " SUB%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IMUL (m, e1, e2) -> sprintf " MUL%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IDIV (m, e1, e2) -> sprintf " DIV%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IMOD (m, e1, e2) -> sprintf " MOD%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISPL (e1, e2) -> sprintf " SPL %s, %s" (pp_rarg e1) (pp_rarg e2) + | IJMP (e1, e2) -> sprintf " JMP %s, %s" (pp_rarg e1) (pp_rarg e2) + | IJMZ (m, e1, e2) -> sprintf " JMZ%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IJMN (m, e1, e2) -> sprintf " JMN%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | IDJN (m, e1, e2) -> sprintf " DJN%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ICMP (m, e1, e2) -> sprintf " CMP%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISEQ (m, e1, e2) -> sprintf " SEQ%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISNE (m, e1, e2) -> sprintf " SNE%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISLT (m, e1, e2) -> sprintf " SLT%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ILDP (m, e1, e2) -> sprintf " LDP%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | ISTP (m, e1, e2) -> sprintf " STP%s %s, %s" (pp_rmod m) (pp_rarg e1) (pp_rarg e2) + | INOP (e1, e2) -> sprintf " NOP %s, %s" (pp_rarg e1) (pp_rarg e2) + + +(* red instruction list to string *) +let pp_instrs (instrs : instruction list) : string = + List.fold_left (fun res i -> res ^ "\r\n" ^ (pp_instr i)) "" instrs diff --git a/dev/util.ml b/dev/util.ml index 6e45100..6b15c49 100644 --- a/dev/util.ml +++ b/dev/util.ml @@ -1,3 +1,149 @@ (** Util **) +open Printf +open Red +open Ast +open Lib +exception CTError of string + +let imode_to_rmode (imode : imode) (place : place) : rmode = + match imode, place with + | MINone, PA -> RAInd + | MINone, PB -> RBInd + | MIDec, PA -> RADec + | MIDec, PB -> RBDec + | MIInc, PA -> RAInc + | MIInc, PB -> RBInc + +let compile_mode (mode : mode) (dest : place) : rmode = + match dest with + | PA -> + (match mode with + | MIns -> RDir + | MImm -> RImm + | MDir -> RDir + | MInd (m) -> (imode_to_rmode m PA) ) + | PB -> + (match mode with + | MIns -> RDir + | MImm -> RImm + | MDir -> RDir + | MInd (m) -> (imode_to_rmode m PB) ) + + +type darg = +| ADRef of mode * int +| ADLab of mode * string + +let arg_to_darg (arg : arg) : darg = + match arg with + | ANone -> ADRef (MImm, 0) + | ANum (n) -> ADRef (MImm, n) + | AId (s) -> ADLab (MDir, s) + | ARef (m, n) -> ADRef (m, n) + | ALab (m, s) -> ADLab (m, s) + | AStore (s) -> raise (CTError (sprintf "Not a valid place to store: %s" s)) + + +type carg = +| ACRef of mode * int (* number variable *) +| ACLab of mode * string (* label variable *) +| ACVar of mode * string (* direct reference *) +| ACPnt of mode * string (* indirect reference *) + +let darg_to_carg (darg : darg) (env : env) : carg = + let _, _, lenv = env in + match darg with + | ADRef (m, n) -> ACRef (m, n) + | ADLab (m, s) -> + (match List.assoc_opt s lenv with + | Some _ -> + (match m with + | MIns | MImm | MDir -> ACVar (m, s) + | MInd (_) -> ACPnt (m, s) ) + | None -> ACLab (m, s) ) + +let carg_to_rarg (carg : carg) (env : env) : rarg = + let _, penv, lenv = env in + match carg with + | ACRef (m, n) -> RRef ((compile_mode m PB), n) + | ACLab (m, s) -> RLab ((compile_mode m PB), s) + | ACVar (m, s) -> + let l = (translate_lenv s lenv) in + RLab ((compile_mode m PB), l) + | ACPnt (m, s) -> + let p = (translate_penv s penv) in + let l = (translate_lenv s lenv) in + RLab ((compile_mode m p), l) + + +let replace_store (arg : arg) (env : env) : arg = + let aenv, _, _ = env in + match arg with + | AStore (s) -> (translate_aenv s aenv) + | _ -> arg + +let compile_arg (arg : arg) (env : env) : carg * rarg = + let arg' = (replace_store arg env) in + let darg = (arg_to_darg arg') in + let carg = (darg_to_carg darg env) in + let rarg = (carg_to_rarg carg env) in + (carg, rarg) + + +type opmod = +| TNum +| TRef +| TA +| TB + +let place_to_opmod (place : place) : opmod = + match place with + | PA -> TA + | PB -> TB + +let carg_to_opmod (carg : carg) (env : env) : opmod = + let aenv, penv, _ = env in + match carg with + | ACRef (m, _) | ACLab (m, _) -> + (match m with + | MImm -> TNum + | MIns | MDir | MInd (_) -> TRef ) + | ACVar (m, s) -> + (match m with + | MIns -> TRef + | MImm | MDir -> + let p = (translate_penv s penv) in + (place_to_opmod p) + | MInd (_) -> raise (CTError ("please report this bug, this error should not happen")) ) + | ACPnt (m, s) -> + (match m with + | MInd (_) -> + let arg = (translate_aenv s aenv) in + let darg = (arg_to_darg arg) in + (match darg with + | ADRef (_, _) -> + (match List.assoc_opt s penv with + | Some p -> (place_to_opmod p) + | None -> TB ) + | ADLab (_, s) -> + (match List.assoc_opt s penv with + | Some p -> (place_to_opmod p) + | None -> TB )) + | MIns | MImm | MDir -> raise (CTError ("please report this bug, this error should not happen")) ) + + +let compile_mod (carg1 : carg) (carg2 : carg) (def : rmod) (env : env) : rmod = + let mod1 = (carg_to_opmod carg1 env) in + let mod2 = (carg_to_opmod carg2 env) in + match mod1, mod2 with + | TNum, TA -> RA + | TNum, TB -> RAB + | TA, TNum -> RAB + | TB, TNum -> RB + | TA, TA -> RA + | TA, TB -> RAB + | TB, TA -> RBA + | TB, TB -> RB + | _, _ -> def diff --git a/dev/verify.ml b/dev/verify.ml deleted file mode 100644 index 210ca21..0000000 --- a/dev/verify.ml +++ /dev/null @@ -1,11 +0,0 @@ -(** Verifier **) -open Printf -open Ast - -exception CTError of string - - -let verify_let (arg : arg) = - match arg with - | AStore (s) -> raise (CTError (sprintf "Not a valid store for var: %s" s)) - | _ -> None