diff options
Diffstat (limited to 'frontend/Wrap.icl')
| -rw-r--r-- | frontend/Wrap.icl | 659 |
1 files changed, 659 insertions, 0 deletions
diff --git a/frontend/Wrap.icl b/frontend/Wrap.icl new file mode 100644 index 0000000..eeb36d8 --- /dev/null +++ b/frontend/Wrap.icl @@ -0,0 +1,659 @@ +implementation module Wrap + +import StdOverloaded + +:: WrappedDescriptorId = {descriptorId :: !Int} + +:: WrappedDescriptor + = WrappedDescriptorCons + | WrappedDescriptorNil + | WrappedDescriptorTuple + | WrappedDescriptorOther !WrappedDescriptorId + +:: WrappedNode + = WrappedInt !Int + | WrappedChar !Char + | WrappedBool !Bool + | WrappedReal !Real + | WrappedFile !File + | WrappedString !{#Char} + | WrappedIntArray !{#Int} + | WrappedBoolArray !{#Bool} + | WrappedRealArray !{#Real} + | WrappedFileArray !{#File} + | WrappedArray !{WrappedNode} + | WrappedRecord !WrappedDescriptor !{WrappedNode} + | WrappedOther !WrappedDescriptor !{WrappedNode} + +instance toString WrappedDescriptorId where + toString :: WrappedDescriptorId -> {#Char} + toString {descriptorId} + = descriptorIDtoString descriptorId + where + descriptorIDtoString :: !Int -> {#Char} + descriptorIDtoString id + = code + { + .d 0 1 i + jsr DtoAC + .o 1 0 + } + +Wrap :: !.a -> WrappedNode +Wrap node + = code + { + | A: <node> <result> + | B: + eq_desc BOOL 0 0 + jmp_false not_a_bool + pushB_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedBool 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_a_bool + + eq_desc INT 0 0 + jmp_false not_an_int + + pushI_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedInt 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_an_int + + eq_desc CHAR 0 0 + jmp_false not_a_char + + pushC_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedChar 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_a_char + + eq_desc REAL 0 0 + jmp_false not_a_real + + pushR_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedReal 0 2 0 0 0 + pop_b 2 + .d 1 0 + rtn + :not_a_real + + eq_desc FILE 0 0 + jmp_false not_a_file + + pushF_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedFile 0 2 0 0 0 + pop_b 2 + .d 1 0 + rtn + :not_a_file + + eq_desc ARRAY 1 0 + jmp_true wrap_array + + eq_desc _ARRAY_ 0 0 + jmp_true wrap__array + + eq_desc _STRING_ 0 0 + jmp_true wrap__string + + is_record 0 + .d 2 0 + jmp_true wrap_record + + get_node_arity 0 + | B: <n> + eqI_b 0 0 + jmp_true wrap_no_args + + :wrap_args + push_a 0 + push_b 0 + push_b 0 + repl_args_b + | A: <arg_1 .. arg_n> <node> <result> + push_b 0 + create_array_ _ 1 0 + | A: <_{args}> <arg_1 .. arg_n> <node> <result> + pushI 0 + + :wrap_args_loop + | A: <_{args}> <arg_(i+1) .. arg_n> <node> <result> + | B: <i> <n> + | wrap arg + push_a 1 + build e_Wrap_sWrap 1 e_Wrap_nWrap + update_a 0 2 + pop_a 1 + + | update i-th element of _args array with wrapped arg + push_b 0 + update _ 1 0 + + | increment index + incI + + push_b 0 + push_b 2 + eqI + jmp_false wrap_args_loop + + pop_b 2 + | A: <_{args}> <node> <result> + | B: + .d 3 0 + jmp wrap_descriptor + + :wrap_no_args + | A: <node> <result> + | B: <0> + create_array_ _ 1 0 + + .o 3 0 + :wrap_descriptor + | A: <_{args}> <node> <result> + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + | A: <node> <_{args}> <result> + eq_nulldesc _Tuple 0 + jmp_false not_a_tuple + build e_Wrap_dWrappedDescriptorTuple 0 _hnf + .d 4 0 + jmp wrap_other + :not_a_tuple + + eq_nulldesc _Cons 0 + jmp_false not_a_cons + build e_Wrap_dWrappedDescriptorCons 0 _hnf + jmp wrap_other + :not_a_cons + + eq_desc _Nil 0 0 + jmp_false not_a_nil + build e_Wrap_dWrappedDescriptorNil 0 _hnf + jmp wrap_other + :not_a_nil + + | A: <node> <_{args}> <result> + pushD_a 0 + build_r e_Wrap_rWrappedDescriptorId 0 1 0 0 + pop_b 1 + + build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0 + update_a 0 1 + pop_a 1 + .o 4 0 + :wrap_other + | A: <descriptor> <node> <_{args}> <result> + update_a 0 1 + pop_a 1 + | A: <descriptor> <_{args}> <result> + fill_r e_Wrap_kWrappedOther 2 0 2 0 0 + pop_a 2 + | A: <result> + .d 1 0 + rtn + + .o 2 0 + :wrap_record + pushI 0 + pushD_a 0 + | A: <node> <result> + | B: <desc> <return> + push_t_r_args + + :wrap_record_fields + | A: <afield_1 .. afield_m> <result> + | B: <l> <bfield_1 .. bfield_n> <desc> <return> + | (l: points to record layout, + | desc: record descriptor + | return: return selector) + push_b 0 + + :count_fields_loop + | A: <afield_1 .. afield_m> <result> + | B: <p> <l> <bfield_1 .. bfield_n> <desc> <return> + | (p=l+offset) + push_b 0 + push_r_arg_t + eqI_b 0 0 + jmp_true end_count_record_fields + pop_b 1 + incI + jmp count_fields_loop + + :end_count_record_fields + pop_b 1 + push_b 0 + update_b 2 1 + subI + | A: <afield_1 .. afield_m> <result> + | B: <n+m> <l> <bfield_1 .. bfield_n> <desc> <return> + create_array_ _ 1 0 + pushI 0 + push_b 1 + update_b 1 2 + update_b 0 1 + pop_b 1 + + :wrap_fields_loop + | A: <_{fields}> <afield_ .. afield_m> <result> + | B: <p> <i> <bfield_ .. bfield_n> <desc> <return> + push_b 0 + push_r_arg_t + eqI_b 0 0 + jmp_true end_wrap_record_fields + eqC_b 'i' 0 + jmp_true wrap_int_field + eqC_b 'c' 0 + jmp_true wrap_char_field + eqC_b 'r' 0 + jmp_true wrap_real_field + eqC_b 'b' 0 + jmp_true wrap_bool_field + eqC_b 'f' 0 + jmp_true wrap_file_field + eqC_b 'a' 0 + jmp_true wrap_graph_field + print_sc "Wrap: unimplemented record field type\n" + halt + + :wrap_int_field + pop_b 1 + + | create and fill int node + create + fillI_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + :wrap_char_field + pop_b 1 + + | create and fill char node + create + fillC_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + :wrap_bool_field + pop_b 1 + + | create and fill bool node + create + fillB_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + + :wrap_real_field + pop_b 1 + + | create and fill real node + create + fillR_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 3 + update_b 0 2 + pop_b 2 + + jmp wrap_field + + :wrap_file_field + pop_b 1 + + | create and fill file node + create + fillF_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 3 + update_b 0 2 + pop_b 2 + + jmp wrap_field + + :wrap_graph_field + pop_b 1 + jmp wrap_field + + :wrap_field + | A: <_{fields}> <field> <afield_ .. afield_m> + | wrap field + push_a 1 + build e_Wrap_sWrap 1 e_Wrap_nWrap + update_a 0 2 + pop_a 1 + + | update i-th element of _fields array with wrapped field + push_b 1 + update _ 1 0 + | A: <_{fields}> <afield_ .. afield_m> <result> + | B: <p> <i> <bfield_ .. bfield_n> <desc> <return> + + | increment index + push_b 1 + incI + update_b 0 2 + + | increment pointer in layout string + pop_b 1 + incI + + jmp wrap_fields_loop + + :end_wrap_record_fields + | A: <_{fields}> <result> + | B: <i=0> <p> <i> <desc> <return> + pop_b 3 + | A: <_{fields}> <result> + | B: <desc> <return> + + | create WrappedDescriptorOther node + build_r e_Wrap_rWrappedDescriptorId 0 1 0 0 + pop_b 1 + build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0 + update_a 0 1 + pop_a 1 + | A: <descriptor> <{fields}> <result> + + | fill result node + fill_r e_Wrap_kWrappedRecord 2 0 2 0 0 + pop_a 2 + + | A: <result> + | B: <return> + | return to caller (determined by the return selector) + eqI_b 0 0 + jmp_true wrap_record_return_node + eqI_b 1 0 + jmp_true wrap_record_array_return + print_sc "Wrap: (record fields) unknown return selector\n" + halt + + :wrap_record_return_node + | A: <result> + | B: <return> + pop_b 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_array + | A: <array> <result> + | replace ARRAY by _ARRAY_ + pushA_a 0 + update_a 0 1 + pop_a 1 + + :wrap__array + | A: <_array> <result> + eq_desc _STRING_ 0 0 + jmp_false not_a_string + + :wrap__string + | fill result node + fill_r e_Wrap_kWrappedString 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + rtn + :not_a_string + + | push array element descriptor + push_r_args_b 0 0 2 2 1 + | A: <_array> <result> + | B: <desc> + push_b 0 + eq_desc_b BOOL 0 + jmp_true wrap_bool_array + push_b 0 + eq_desc_b INT 0 + jmp_true wrap_int_array + push_b 0 + eq_desc_b REAL 0 + jmp_true wrap_real_array + push_b 0 + eq_desc_b FILE 0 + jmp_true wrap_file_array + + pushI 0 + push_a 0 + push_arraysize _ 0 1 + | A: <_array> <result> + | B: <n> <i> <desc> + push_b 2 + update_b 2 3 + update_b 1 2 + update_b 0 1 + pop_b 1 + | B: <desc> <n> <i> + pushI 0 + eqI + | B: <n> <i> + jmp_false wrap_record_array + + push_b 0 + create_array_ _ 1 0 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + .d 3 2 i i + jmp wrap_array_test + + .o 3 2 i i + :wrap_array_elements + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + + | wrap element + push_b 1 + push_a 1 + select _ 1 0 + build e_Wrap_sWrap 1 e_Wrap_nWrap + | A: <element> <_wrapped_array> <_array> <result> + | B: <n> <i> + | update i-th element of _wrapped_array with wrapped element + push_a 1 + push_b 1 + update _ 1 0 + update_a 0 1 + pop_a 1 + | B: <n> <i> + | increment index + push_b 1 + incI + update_b 0 2 + + | decrement n + pop_b 1 + decI + + .o 3 2 i i + :wrap_array_test + | B: <n> <i> + eqI_b 0 0 + .d 3 2 i i + jmp_false wrap_array_elements + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + pop_b 2 + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <result> + | B: + | fill result node + fill_r e_Wrap_kWrappedArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + + :wrap_bool_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedBoolArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_int_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedIntArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_real_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedRealArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_file_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedFileArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_record_array + | A: <_array> <result> + | B: <n> <i> + push_b 0 + create_array_ _ 1 0 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + + jmp wrap_record_array_test + + :wrap_record_array_loop + | B: <n> <i> + pushI 1 + | push record element descriptor + push_r_args_b 1 0 2 2 1 + | B: <desc> <return> <n> <i> + + | create result node for wrap_record_fields + create + + | push fields from i-th array element + push_b 3 + push_a 2 + push_a_r_args + | A: <afield_1 .. afield_m> <elresult> <_wrapped_array> <_array> <result> + | B: <l> <bfieldb_1 .. bfield_n> <desc> <return> <n> <i> + | wrap record element + jmp wrap_record_fields + :wrap_record_array_return + | A: <element> <_wrapped_array> <_array> <result> + | B: <return> <n> <i> + pop_b 1 + | A: <element> <_wrapped_array> <_array> <result> + | B: <n> <i> + | update i-th of _wrapped_array with wrapped record element + push_a 1 + push_b 1 + update _ 1 0 + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + | increment index + push_b 1 + incI + update_b 0 2 + pop_b 1 + + | decrement n + decI + + :wrap_record_array_test + eqI_b 0 0 + jmp_false wrap_record_array_loop + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + pop_b 2 + | B: + + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <result> + | fill result node + fill_r e_Wrap_kWrappedArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + } |