:- module construct.
:- use_module builtin, list, private_builtin, std_util, type_desc.
:- pragma foreign_import_module("C", construct).
:- func construct:null_to_no(string) = (std_util:maybe(string)).
:- mode construct:null_to_no((builtin:in)) = (builtin:out) is det.
:- pred construct:null(string).
:- mode construct:null((builtin:in)) is semidet.
:- pred construct:get_functor_2((type_desc:type_desc), int, string, int, (list:list((type_desc:type_desc))), (list:list(string))).
:- mode construct:get_functor_2((builtin:in), (builtin:in), (builtin:out), (builtin:out), (builtin:out), (builtin:out)) is semidet.
:- func construct:construct_tuple_2((list:list((std_util:univ))), (list:list((type_desc:type_desc))), int) = (std_util:univ).
:- mode construct:construct_tuple_2((builtin:in), (builtin:in), (builtin:in)) = (builtin:out) is det.
:- pragma foreign_proc("C", construct:num_functors(TypeInfo :: (builtin:in)) = (Functors :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
	MR_save_transient_registers();
	Functors = MR_get_num_functors((MR_TypeInfo) TypeInfo);
	MR_restore_transient_registers();
}").
:- pragma foreign_proc("C", construct:get_functor(TypeDesc :: (builtin:in), FunctorNumber :: (builtin:in), FunctorName :: (builtin:out), Arity :: (builtin:out), TypeInfoList :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
    MR_TypeInfo         type_info;
    MR_Construct_Info   construct_info;
    int                 arity;
    MR_bool             success;

    type_info = (MR_TypeInfo) TypeDesc;

        /*
        ** Get information for this functor number and
        ** store in construct_info. If this is a discriminated union
        ** type and if the functor number is in range, we
        ** succeed.
        */
    MR_save_transient_registers();
    success = MR_get_functors_check_range(FunctorNumber,
                type_info, &construct_info);
    MR_restore_transient_registers();

        /*
        ** Get the functor name and arity, construct the list
        ** of type_infos for arguments.
        */

    if (success) {
        MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
                construct_info.functor_name);
        arity = construct_info.arity;
        Arity = arity;

        if (MR_TYPE_CTOR_INFO_IS_TUPLE(
                        MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
        {
            MR_save_transient_registers();
            TypeInfoList = MR_type_params_vector_to_list(Arity,
                    MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
            MR_restore_transient_registers();
        } else {
            MR_save_transient_registers();
            TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
                arity,
                MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
                construct_info.arg_pseudo_type_infos);
            MR_restore_transient_registers();
        }
    }
    SUCCESS_INDICATOR = success;
}").
construct:get_functor(TypeDesc_7, I_8, Functor_9, Arity_10, TypeInfoList_11, ArgNameList_12) :-
		construct:get_functor_2(TypeDesc_7, I_8, Functor_9, Arity_10, TypeInfoList_11, ArgNameList0_13),
		ArgNameList_12 = list:map(V_14, ArgNameList0_13),
		V_14 = construct:null_to_no.
:- pragma foreign_proc("C", construct:get_functor_ordinal(TypeDesc :: (builtin:in), FunctorNumber :: (builtin:in), Ordinal :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
    MR_TypeInfo         type_info;
    MR_Construct_Info   construct_info;
    MR_bool             success;

    type_info = (MR_TypeInfo) TypeDesc;

        /*
        ** Get information for this functor number and
        ** store in construct_info. If this is a discriminated union
        ** type and if the functor number is in range, we
        ** succeed.
        */
    MR_save_transient_registers();
    success = MR_get_functors_check_range(FunctorNumber, type_info,
        &construct_info);
    MR_restore_transient_registers();

    if (success) {
        switch (construct_info.type_ctor_rep) {

        case MR_TYPECTOR_REP_ENUM:
        case MR_TYPECTOR_REP_ENUM_USEREQ:
            Ordinal = construct_info.functor_info.
                enum_functor_desc->MR_enum_functor_ordinal;
            break;

        case MR_TYPECTOR_REP_NOTAG:
        case MR_TYPECTOR_REP_NOTAG_USEREQ:
        case MR_TYPECTOR_REP_NOTAG_GROUND:
        case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
        case MR_TYPECTOR_REP_TUPLE:
            Ordinal = 0;
            break;

        case MR_TYPECTOR_REP_DU:
        case MR_TYPECTOR_REP_DU_USEREQ:
        case MR_TYPECTOR_REP_RESERVED_ADDR:
        case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
            Ordinal = construct_info.functor_info.
                du_functor_desc->MR_du_functor_ordinal;
            break;

        default:
            success = MR_FALSE;

        }
    }
    SUCCESS_INDICATOR = success;
}").
:- pragma foreign_proc("C", construct:construct(TypeDesc :: (builtin:in), FunctorNumber :: (builtin:in), ArgList :: (builtin:in)) = (Term :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
    MR_TypeInfo         type_info;
    MR_TypeCtorInfo     type_ctor_info;
    MR_Word             new_data;
    MR_Construct_Info   construct_info;
    MR_bool             success;

    type_info = (MR_TypeInfo) TypeDesc;

        /*
        ** Check range of FunctorNum, get info for this
        ** functor.
        */
    MR_save_transient_registers();
    success =
        MR_get_functors_check_range(FunctorNumber, type_info, &construct_info)
        && MR_typecheck_arguments(type_info, construct_info.arity, ArgList,
                construct_info.arg_pseudo_type_infos);
    MR_restore_transient_registers();

        /*
        ** Build the new term in `new_data\'.
        */
    if (success) {

        type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);

        if (MR_type_ctor_rep(type_ctor_info) != construct_info.type_ctor_rep) {
            MR_fatal_error(\"construct:construct: type_ctor_rep mismatch\");
        }

        switch (MR_type_ctor_rep(type_ctor_info)) {

        case MR_TYPECTOR_REP_ENUM:
        case MR_TYPECTOR_REP_ENUM_USEREQ:
            new_data = construct_info.functor_info.enum_functor_desc->
                MR_enum_functor_ordinal;
            break;

        case MR_TYPECTOR_REP_NOTAG:
        case MR_TYPECTOR_REP_NOTAG_USEREQ:
        case MR_TYPECTOR_REP_NOTAG_GROUND:
        case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
            if (MR_list_is_empty(ArgList)) {
                MR_fatal_error(\"notag arg list is empty\");
            }

            if (! MR_list_is_empty(MR_list_tail(ArgList))) {
                MR_fatal_error(\"notag arg list is too long\");
            }

            new_data = MR_field(MR_UNIV_TAG, MR_list_head(ArgList),
                MR_UNIV_OFFSET_FOR_DATA);
            break;

        case MR_TYPECTOR_REP_RESERVED_ADDR:
        case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
	    /*
	    ** First check whether the functor we want is one of the
	    ** reserved addresses.
	    */
	    {
		int i;
		MR_ReservedAddrTypeLayout ra_layout;
		int total_reserved_addrs;
		const MR_ReservedAddrFunctorDesc *functor_desc;

		ra_layout = MR_type_ctor_layout(type_ctor_info).
			MR_layout_reserved_addr;
		total_reserved_addrs = ra_layout->MR_ra_num_res_numeric_addrs
			+ ra_layout->MR_ra_num_res_symbolic_addrs;

		for (i = 0; i < total_reserved_addrs; i++) {
		    functor_desc = ra_layout->MR_ra_constants[i];
		    if (functor_desc->MR_ra_functor_ordinal == FunctorNumber)
		    {
		    	new_data = (MR_Word)
			    functor_desc->MR_ra_functor_reserved_addr;

		        /* `break\' here would just exit the `for\' loop */
			goto end_of_main_switch;
		    }
		}
	    }
		    
	    /*
	    ** Otherwise, it is not one of the reserved addresses,
	    ** so handle it like a normal DU type.
	    */

	    /* fall through */

        case MR_TYPECTOR_REP_DU:
        case MR_TYPECTOR_REP_DU_USEREQ:
            {
                const MR_DuFunctorDesc  *functor_desc;
                MR_Word                 arg_list;
                MR_Word                 ptag;
                MR_Word                 arity;
                int                     i;

                functor_desc = construct_info.functor_info.du_functor_desc;
                if (functor_desc->MR_du_functor_exist_info != NULL) {
                    MR_fatal_error(\"not yet implemented: construction \"
                        \"of terms containing existentially types\");
                }

                arg_list = ArgList;
                ptag = functor_desc->MR_du_functor_primary;
                switch (functor_desc->MR_du_functor_sectag_locn) {
                case MR_SECTAG_LOCAL:
                    new_data = (MR_Word) MR_mkword(ptag,
                        MR_mkbody((MR_Word)
                            functor_desc->MR_du_functor_secondary));
                    break;

                case MR_SECTAG_REMOTE:
                    arity = functor_desc->MR_du_functor_orig_arity;

                    MR_tag_incr_hp_msg(new_data, ptag, arity + 1,
                        MR_PROC_LABEL, \"<created by construct:construct/3>\");

                    MR_field(ptag, new_data, 0) =
                        functor_desc->MR_du_functor_secondary;
                    for (i = 0; i < arity; i++) {
                        MR_field(ptag, new_data, i + 1) =
                            MR_field(MR_UNIV_TAG, 
			    	MR_list_head(arg_list),
                                MR_UNIV_OFFSET_FOR_DATA);
                        arg_list = MR_list_tail(arg_list);
                    }

                    break;

                case MR_SECTAG_NONE:
                    arity = functor_desc->MR_du_functor_orig_arity;

                    MR_tag_incr_hp_msg(new_data, ptag, arity,
                        MR_PROC_LABEL, \"<created by construct:construct/3>\");

                    for (i = 0; i < arity; i++) {
                        MR_field(ptag, new_data, i) =
                            MR_field(MR_UNIV_TAG, 
			    	MR_list_head(arg_list),
                                MR_UNIV_OFFSET_FOR_DATA);
                        arg_list = MR_list_tail(arg_list);
                    }

                    break;
                case MR_SECTAG_VARIABLE:
		    MR_fatal_error(\"construct(): cannot construct variable\");
                }

                if (! MR_list_is_empty(arg_list)) {
                    MR_fatal_error(\"excess arguments in construct:construct\");
                }
            }
            break;

        case MR_TYPECTOR_REP_TUPLE:
            {
                int    	arity;
		int	i;
                MR_Word    arg_list;

                arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
    
                if (arity == 0) {
                    new_data = (MR_Word) NULL;
                } else {
                    MR_incr_hp_msg(new_data, arity, MR_PROC_LABEL,
                            \"<created by construct:construct/3>\");
            
                    arg_list = ArgList;
                    for (i = 0; i < arity; i++) {
                        MR_field(MR_mktag(0), new_data, i) =
                            MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
                                    MR_UNIV_OFFSET_FOR_DATA);
                        arg_list = MR_list_tail(arg_list);
                    }

                    if (! MR_list_is_empty(arg_list)) {
                        MR_fatal_error(
                                \"excess arguments in construct:construct\");
                    }
                }
            }
            break;

        default:
            MR_fatal_error(\"bad type_ctor_rep in construct:construct\");
        }

    end_of_main_switch:

        /*
        ** Create a univ.
        */

        MR_new_univ_on_hp(Term, type_info, new_data);
    }

    SUCCESS_INDICATOR = success;
}").
construct:construct_tuple(Args_3) = HeadVar__2_2 :-
		HeadVar__2_2 = construct:construct_tuple_2(Args_3, V_4, V_5),
		V_4 = list:map(V_6, Args_3),
		V_6 = std_util:univ_type,
		V_5 = list:length(Args_3).
construct:null_to_no(S_3) = HeadVar__2_2 :-
		(if
			construct:null(S_3)
		then
			HeadVar__2_2 = std_util:no
		else
			HeadVar__2_2 = std_util:yes(S_3)
		).
:- pragma foreign_proc("C", construct:null(S :: (builtin:in)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "
    SUCCESS_INDICATOR = (S == NULL);
").
:- pragma foreign_proc("C", construct:get_functor_2(TypeDesc :: (builtin:in), FunctorNumber :: (builtin:in), FunctorName :: (builtin:out), Arity :: (builtin:out), TypeInfoList :: (builtin:out), ArgNameList :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
    MR_TypeInfo         type_info;
    MR_Construct_Info   construct_info;
    int                 arity;
    MR_bool             success;

    type_info = (MR_TypeInfo) TypeDesc;

        /*
        ** Get information for this functor number and
        ** store in construct_info. If this is a discriminated union
        ** type and if the functor number is in range, we
        ** succeed.
        */
    MR_save_transient_registers();
    success = MR_get_functors_check_range(FunctorNumber,
                type_info, &construct_info);
    MR_restore_transient_registers();

        /*
        ** Get the functor name and arity, construct the list
        ** of type_infos for arguments.
        */

    if (success) {
        MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
                construct_info.functor_name);
        arity = construct_info.arity;
        Arity = arity;

        if (MR_TYPE_CTOR_INFO_IS_TUPLE(
                        MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
        {
	    int i;
            MR_save_transient_registers();
            TypeInfoList = MR_type_params_vector_to_list(Arity,
                    MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
            ArgNameList = MR_list_empty();
            for (i = 0; i < Arity; i++) {
                ArgNameList = MR_list_cons_msg((MR_Word) NULL,
                                ArgNameList, MR_PROC_LABEL);
            }
            MR_restore_transient_registers();
        } else {
            MR_save_transient_registers();
            TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
                arity, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
                construct_info.arg_pseudo_type_infos);
            ArgNameList = MR_arg_name_vector_to_list(
                arity, construct_info.arg_names);
            MR_restore_transient_registers();
        }
    }
    SUCCESS_INDICATOR = success;
}").
:- pragma foreign_proc("C", construct:construct_tuple_2(Args :: (builtin:in), ArgTypes :: (builtin:in), Arity :: (builtin:in)) = (Term :: (builtin:out)), [will_not_call_mercury, thread_safe, not_tabled_for_io, promise_pure], "{
	MR_TypeInfo type_info;
	MR_Word new_data;
	MR_Word arg_value;
	int i;

	/*
	** Construct a type_info for the tuple.
	*/
	MR_save_transient_registers();
	type_info = MR_make_type(Arity, MR_TYPECTOR_DESC_MAKE_TUPLE(Arity),
			ArgTypes);
	MR_restore_transient_registers();

	/*
	** Create the tuple.
	*/
	if (Arity == 0) {
		new_data = (MR_Word) NULL;
	} else {
		MR_incr_hp_msg(new_data, Arity, MR_PROC_LABEL,
			\"<created by construct:construct_tuple/1>\");
		for (i = 0; i < Arity; i++) {
			arg_value = MR_field(MR_UNIV_TAG, 
					MR_list_head(Args),
					MR_UNIV_OFFSET_FOR_DATA);
			MR_field(MR_mktag(0), new_data, i) = arg_value;
			Args = MR_list_tail(Args);
		}
	}

	/*
	** Create a univ.
	*/
	MR_new_univ_on_hp(Term, type_info, new_data);
}").
:- pragma termination_info(construct:num_functors((builtin:in)) = (builtin:out), infinite, cannot_loop).
:- pragma termination_info(construct:get_functor((builtin:in), (builtin:in), (builtin:out), (builtin:out), (builtin:out)), infinite, cannot_loop).
:- pragma termination_info(construct:get_functor((builtin:in), (builtin:in), (builtin:out), (builtin:out), (builtin:out), (builtin:out)), infinite, can_loop).
:- pragma termination_info(construct:get_functor_ordinal((builtin:in), (builtin:in), (builtin:out)), infinite, cannot_loop).
:- pragma termination_info(construct:construct((builtin:in), (builtin:in), (builtin:in)) = (builtin:out), infinite, cannot_loop).
:- pragma termination_info(construct:construct_tuple((builtin:in)) = (builtin:out), infinite, can_loop).