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
	}