let rec compile_datatype_init dt = match dt with
(Ast.SynIntType
| Ast.SynFloatType
| Ast.SynStringType
| Ast.SynBoolType
| Ast.SynVoidType
| Ast.SynRefType _) -> [Instruction ConstUninit]
| Ast.SynEnumOrStructType (name,field_types) ->
if List.length !field_types > 0 then
let n_fields = List.length !field_types in
let fields_result = compile_datatypes_pushing !field_types in
fields_result
@ [Instruction (Rev n_fields)]
@ [Instruction (MakeBlockStatic (1,n_fields))]
else
[Instruction ConstUninit]
| Ast.SynArrayType (t_arr,vprod) ->
let dt_code = compile_datatype_init t_arr in
let vprod_code = compile_value_producer vprod in
dt_code
@ [Instruction Push]
@ vprod_code
@ [Instruction (MakeBlockFilled 0)]
| Ast.SynListType _ ->
[Instruction Nil]
| Ast.SynArrowType (_,_) -> [Instruction (ConstString "")]
and compile_datatypes_pushing dt_list = match dt_list with
dt::rest -> (compile_datatype_init dt)@[Instruction Push]@(compile_datatypes_pushing rest)
| [] -> []
and compile_expression expr = match expr with
Ast.SynVarDeclare vdecl -> compile_variable_declaration vdecl
| Ast.SynEnumDeclare edecl -> []
| Ast.SynVarAssign vasgn -> compile_variable_assignment vasgn
| Ast.SynCond cond -> compile_conditional cond
| Ast.SynLoop loop -> compile_loop loop
| Ast.SynFunctionCall funcall -> compile_function_call funcall
| Ast.SynReturnStatement ret -> compile_return ret
| Ast.SynBreak -> [Break]
| Ast.SynContinue -> [Continue]
and compile_expression_list expr_list = match expr_list with
cur::rest ->
let curbuf = compile_expression cur in
let restbuf = compile_expression_list rest in
curbuf@restbuf
| [] -> []
and compile_variable_declaration vdecl = match vdecl with
Ast.SynVarDeclareNoInit (dt, varname) ->
let dt_init = compile_datatype_init dt in
dt_init @ [SetVar varname]
| Ast.SynVarDeclareWithInit(_, varname, vprod) ->
let valbuf = compile_value_producer vprod in
valbuf@[SetVar varname]
and compile_conditional cond = match cond with
Ast.SynIf (vp,expr_list) ->
let vp_result = compile_value_producer vp in
let expr_result = compile_expression_list expr_list in
[If (vp_result, expr_result, [])]
| Ast.SynIfCase (vp,expr_list,continued_cond) ->
let vp_result = compile_value_producer vp in
let expr_result = compile_expression_list expr_list in
let continued_result = compile_continued_conditional continued_cond in
[If (vp_result, expr_result, continued_result)]
and compile_continued_conditional cond = match cond with
Ast.SynFinalElse expr_list -> compile_expression_list expr_list
| Ast.SynElse cond -> compile_conditional cond
and compile_loop loop = match loop with
Ast.SynWhile (vprod,lexpr_list) ->
let vp_result = compile_value_producer vprod in
let lexpr_result = compile_expression_list lexpr_list in
[While (vp_result,lexpr_result)]
| Ast.SynFor (init,test,step,body) ->
let init_result = compile_expression init in
let test_result = compile_value_producer test in
let step_result = compile_expression step in
let body_result = compile_expression_list body in
[For (init_result, test_result, step_result, body_result)]
| Ast.SynDoWhile (lexpr_list, vprod) ->
let vp_result = compile_value_producer vprod in
let lexpr_result = compile_expression_list lexpr_list in
[While (lexpr_result,vp_result)]
and compile_value value = match value with
Ast.SynIntValue i -> [Instruction (ConstInt i)]
| Ast.SynFloatValue f -> [Instruction (ConstFloat f)]
| Ast.SynBoolValue b -> [Instruction (ConstInt (if b then 1 else 0))]
| Ast.SynStringValue s -> [Instruction (ConstString s)]
and compile_value_producer vprod = match vprod with
Ast.SynValue value -> compile_value value
| Ast.SynFunctionCallValue funcall -> compile_function_call funcall
| Ast.SynVarIdentifier vident -> compile_get_variable_identifier vident
| Ast.SynBinop (vp1,op,vp2) -> compile_binary_operation vp1 op vp2
| Ast.SynPrefixUnop (op,vp) -> compile_prefix_unary_operation op vp
| Ast.SynParenthesized vprod -> compile_value_producer vprod
| Ast.SynArrayValueProducer vprod_list ->
let n = List.length vprod_list in
let values_result = compile_value_producer_list_pushing vprod_list in
values_result
@ [Instruction (Rev n);
Instruction (MakeBlockStatic (0,n))]
| Ast.SynListValueProducer lvprod -> compile_list_value_producer lvprod
and compile_value_producer_list_pushing vp_list = match vp_list with
cur::rest ->
let cur_result = compile_value_producer cur in
let rest_result= compile_value_producer_list_pushing rest in
cur_result
@ [Instruction Push]
@ rest_result
| [] -> []
and compile_list_value_producer lvprod = match lvprod with
Ast.SynListNil _ -> [Instruction Nil]
| Ast.SynListList vprod_list ->
let result = compile_value_producer_list_pushing vprod_list in
result
@ [Instruction Nil]
@ (repeat_list [Instruction Cons] (List.length vprod_list))
| Ast.SynListCons (vp1,vp2) ->
let result_car = compile_value_producer vp1 in
let result_cdr = compile_value_producer vp2 in
result_car
@ [Instruction Push]
@ result_cdr
@ [Instruction Cons]
and compile_variable_assignment vasgn = match vasgn with
Ast.SynVarAssignment (vident,vprod) ->
let vp_result = compile_value_producer vprod in
let setvar_result = compile_set_variable_identifier vident in
vp_result @ setvar_result
| Ast.SynVarModify (vident, op, vprod) ->
let vp1, vp2 = Ast.SynVarIdentifier vident, vprod
in
let op_result = compile_value_producer
(Ast.SynBinop (vp1, op, vp2)) in
let setvar_result = compile_set_variable_identifier vident in
op_result @ setvar_result
and compile_set_variable_identifier vident =
match vident with
Ast.SynVarName s -> [SetVar s]
| Ast.SynStructOrEnumValue (vid1,s2,ftype) ->
(match !ftype with
Ast.VIdStructField index ->
let getstruct = compile_get_variable_identifier vid1 in
[Instruction Push]
@ getstruct
@ [Instruction (SetElemStatic index)]
| Ast.VIdEnumValue _ ->
raise_compile_error ["Unexpected compile error: cannot set an enum value."]
| Ast.VIdUnspecified ->
raise_compile_error ["Unexpected compile error: field index ";s2;" was not determined by type checker."])
| Ast.SynArrayCell (vid,vprod) ->
let vid_result = compile_get_variable_identifier vid in
let vprod_result = compile_value_producer vprod in
[Instruction Push]
@ vprod_result
@ [Instruction Push]
@ vid_result
@ [Instruction SetElem]
and compile_get_variable_identifier vident =
match vident with
Ast.SynVarName s -> [GetVar s]
| Ast.SynStructOrEnumValue (vid1,s2,ftype) ->
(match !ftype with
Ast.VIdStructField index ->
let getstruct = compile_get_variable_identifier vid1 in
getstruct @ [Instruction (GetElemStatic index)]
| Ast.VIdEnumValue index ->
[Instruction (ConstInt index)]
| Ast.VIdUnspecified ->
raise_compile_error ["Unexpected compile error: field index ";s2;" was not determined by type checker."])
| Ast.SynArrayCell (vid,vprod) ->
let vid_result = compile_get_variable_identifier vid in
let vprod_result = compile_value_producer vprod in
vprod_result
@ [Instruction Push]
@ vid_result
@ [Instruction GetElem]
and compile_binary_operation vp1 op vp2 =
let vp1_result = compile_value_producer vp1 in
let vp2_result = compile_value_producer vp2 in
let op_command = match op with
Ast.SynBinopAnd -> [Instruction And]
| Ast.SynBinopOr -> [Instruction Or]
| Ast.SynBinopAdd -> [Instruction Add]
| Ast.SynBinopSub -> [Instruction Sub]
| Ast.SynBinopMul -> [Instruction Mul]
| Ast.SynBinopDiv -> [Instruction Div]
| Ast.SynBinopIDiv ->[Instruction DivI]
| Ast.SynBinopMod -> [Instruction RemI]
| Ast.SynBinopConcat -> [Instruction Concat]
| Ast.SynBinopCons -> [Instruction Cons]
| Ast.SynCompLt -> [Instruction Lt]
| Ast.SynCompGt -> [Instruction Gt]
| Ast.SynCompLte ->[Instruction Lte]
| Ast.SynCompGte ->[Instruction Gte]
| Ast.SynCompEq -> [Instruction Eq]
| Ast.SynCompNeq ->[Instruction Neq]
in
vp2_result
@ [Instruction Push]
@ vp1_result
@ op_command
and compile_prefix_unary_operation op vp =
let vp_result = compile_value_producer vp in
let op_command = match op with
Ast.SynUnopNot -> [Instruction Push;
Instruction (ConstInt 1);
Instruction Add;
Instruction Push;
Instruction (ConstInt 2);
Instruction Swap;
Instruction RemI]
| Ast.SynUnopCar -> [Instruction Car]
| Ast.SynUnopCdr -> [Instruction Cdr]
| Ast.SynUnopTrunc -> [Instruction Int]
| Ast.SynUnopDeref -> [Instruction (GetElemStatic 0)]
| Ast.SynUnopNeg -> [Instruction Neg]
| Ast.SynUnopNull -> [Instruction IsNull]
in
vp_result @ op_command
and compile_function_call funcall = match funcall with
Ast.SynLocalCall (fname,vprod_list,isvar) ->
let n_args = List.length vprod_list in
let args_result = compile_value_producer_list_pushing vprod_list in
let ret_label = make_label (concat ["returnfrom_local_";fname]) in
let call_instruction =
if !isvar then
[GetVar fname;
Instruction Apply]
else
[Instruction (Call fname)]
in
[Instruction (Comment (concat ["Local call to ";fname]));
Instruction (PushSf ret_label);
BeginScope]
@ args_result
@ [Instruction (Rev n_args)]
@ call_instruction
@ [EndScopeSf;
Instruction (Label ret_label)]
| Ast.SynRemoteCall (fname,vprod_list,ret_var) ->
let n_args = List.length vprod_list in
let args_result = compile_value_producer_list_pushing vprod_list in
let ret_label = make_label (concat ["returnfrom_remote_withresult_";fname]) in
let done_label = make_label (concat ["done_interpreting_remote_results_";fname]) in
let vident_set_result = compile_set_variable_identifier ret_var in
[Instruction (Comment (concat ["Remote call with result to ";fname]));
Instruction (PushSf ret_label);
BeginScope]
@ args_result
@ [Instruction (Rev n_args);
Instruction (RPC fname);
EndScopeSfRPC;
Instruction (Label ret_label);
Instruction (Jz done_label);
Instruction Swap]
@ vident_set_result
@ [Instruction Swap;
Instruction (Label done_label);
Instruction Swap;
Instruction (Acc 0);
Instruction Pop]
| Ast.SynRemoteCallNoResult (fname, vprod_list) ->
let n_args = List.length vprod_list in
let args_result = compile_value_producer_list_pushing vprod_list in
let ret_label = make_label (concat ["returnfrom_local_";fname]) in
[Instruction (Comment (concat ["Remote call with no result to ";fname]));
Instruction (PushSf ret_label);
BeginScope]
@ args_result
@ [Instruction (Rev n_args);
Instruction (RPC fname);
EndScopeSfRPC;
Instruction (Label ret_label);
Instruction Swap;
Instruction (Acc 0);
Instruction Pop]
and compile_return ret = match ret with
Ast.SynVoidReturn ->
[Instruction ConstUninit; Instruction Return]
| Ast.SynValueReturn vprod ->
let vp_result = compile_value_producer vprod in
vp_result@[Instruction Return]