let rec compile_ir_instruction inst env = match inst with
Instruction i -> [i], offset_locs (get_stack_offset i) env
| GetVar v ->
if isdef v env then
(match get_loc v env with
StackLoc loc ->
[Acc loc], env
| GlobalLoc loc ->
[GetField loc], env
| FunctionLoc funname ->
[ConstString funname], env)
else
raise_compile_error ["Error in instruction GetVar, ";v;" was not defined."]
| SetVar v ->
if isdef v env then
(match get_loc v env with
StackLoc loc ->
[Assign loc], env
| GlobalLoc loc ->
[SetField loc], env
| FunctionLoc name ->
raise_compile_error ["Unexpected compile error: attempted to re-define function ";name;"."])
else
[Push], add_loc (v,StackLoc 0) (offset_locs 1 env)
| NoteVar (v,i) -> [], add_loc (v,StackLoc i) env
| NoteFunction name -> [], add_loc (name,FunctionLoc name) env
| If (test,thenbody,elsebody) ->
let else_label = make_label "else" in
let endif_label = make_label "endif" in
let test_result,_ = compile_ir_instruction_list test env in
let then_result,then_env = compile_ir_instruction_list thenbody (add_frame env) in
let else_result,else_env = compile_ir_instruction_list elsebody (add_frame env) in
let restore_code_then = get_restore_code then_env in
let restore_code_else = get_restore_code else_env in
[Comment "if"]
@ test_result
@ [Jz else_label]
@ then_result
@ restore_code_then
@ [Jmp endif_label;
Label else_label]
@ else_result
@ restore_code_else
@ [Label endif_label]
@ [Comment "endif"], env
| For (init, test, step, body) ->
let test_label = make_label "for_test" in
let endfor_label = make_label "for_end" in
let init_result,init_env = compile_ir_instruction_list init (add_frame env) in
let restore_init = get_restore_code init_env in
let test_result,_ = compile_ir_instruction_list test init_env in
let env_for_body = set_loop_info (LoopBreakContinue (endfor_label,test_label)) (add_frame init_env) in
let body_result,body_env = compile_ir_instruction_list body env_for_body in
let restore_body = get_restore_code body_env in
let step_result,step_env = compile_ir_instruction_list step (add_frame init_env) in
let restore_step = get_restore_code step_env in
[Comment "for"]
@ init_result
@ [Label test_label]
@ test_result
@ [Jz endfor_label]
@ body_result
@ restore_body
@ step_result
@ restore_step
@ [Jmp test_label]
@ [Label endfor_label]
@ restore_init
@ [Comment "end for"], env
| While (test, body) ->
let test_label = make_label "while" in
let wend_label = make_label "wend" in
let test_result,_ = compile_ir_instruction_list test env in
let env_for_body = set_loop_info (LoopBreakContinue (wend_label,test_label)) (add_frame env) in
let body_result,body_env = compile_ir_instruction_list body env_for_body in
let restore_body = get_restore_code body_env in
[Comment "while"]
@ [Label test_label]
@ test_result
@ [Jz wend_label]
@ body_result
@ restore_body
@ [Jmp test_label]
@ [Label wend_label]
@ [Comment "wend"], env
| DoWhile (body,test) ->
let do_label = make_label "do" in
let end_label = make_label "end_dowhile" in
let test_result,_ = compile_ir_instruction_list test env in
let env_for_body = set_loop_info (LoopBreakContinue (end_label,do_label)) (add_frame env) in
let body_result,body_env = compile_ir_instruction_list body env_for_body in
let restore_body = get_restore_code body_env in
[Comment "dowhile"]
@ [Label do_label]
@ body_result
@ restore_body
@ [Comment "dowhile_test"]
@ test_result
@ [Jnz do_label]
@ [Label end_label]
@ [Comment "end dowhile"], env
| Break ->
let restore_code = get_breakcontinue_restore env in
restore_code @ [Jmp (get_break_label env)], env
| Continue ->
let restore_code = get_breakcontinue_restore env in
restore_code @ [Jmp (get_continue_label env)], env
| BeginScope -> [], add_frame env
| EndScope -> [], remove_frame env
| EndScopeSf -> [], offset_locs (-2) (remove_frame env)
| EndScopeSfRPC -> [], offset_locs (-1) (remove_frame env)
| DeclareGlobal s ->
let n = (n_globals env) in
[], add_loc (s,GlobalLoc n) env
and compile_ir_instruction_list ir_buf env = match ir_buf with
cur::rest ->
let cur_result,new_env = compile_ir_instruction cur env in
let rest_result,final_env = compile_ir_instruction_list rest new_env in
cur_result @ rest_result, final_env
| [] -> [], env