note

	description:
		"32 bit DLL routine for Windows"
	legal: "See notice at end of class."

	status: "See notice at end of class."
	date: "$Date$"
	revision: "$Revision$"

class DLL_32_ROUTINE

obsolete
	"This class should no longer be used due to platform dependence and non-64bit compliance"

inherit
	SHARED_LIBRARY_ROUTINE
		redefine
			shared_library
		end

create
	make_by_name, make_by_index

feature

	make_by_index (lib: DLL_32; r_index: INTEGER;
				arg_types: ARRAY [INTEGER]; ret_type: INTEGER)
			-- Connect to the routine of index `r_index' in library `lib'
		require
			library_exists: lib /= Void
			meaningful: lib.meaningful
			valid_index: r_index > 0
			valid_argument_array: arg_types /= Void
			valid_argument_types: valid_argument_types (arg_types)
			valid_return_type: valid_return_type (ret_type)
		do
			shared_library := lib
			library_index := r_index
			function_handle := desc_get_function_index_pointer (lib.module_handle, r_index)
			if function_handle /= default_pointer then
				error_code := No_error
			else
				error_code := No_routine
			end
			argument_types := arg_types
			return_type := ret_type
			make_argument_array
			routine_called := False
		ensure
			consistent_index: library_index = r_index
			consistent_lib: lib = shared_library
			routine_not_called: not routine_called
		end

	make_by_name (lib: DLL_32; f_name: STRING;
				arg_types: ARRAY [INTEGER]; ret_type: INTEGER)
			-- Connect to the routine `f_name' in library `lib'
		local
			c_func_name: ANY
		do
			shared_library := lib
			function_name := f_name
			c_func_name := f_name.to_c
			function_handle := win_get_proc_address (lib.module_handle, $c_func_name)
			if function_handle /= default_pointer then
				error_code := No_error
			else
				error_code := No_routine
			end
			argument_types := arg_types
			return_type := ret_type
			make_argument_array
			routine_called := False
		end

feature -- Basic operations

	call (args: ARRAY [ANY])
			-- Call the routine with actual arguments `args'
		local
			formal_args: ANY
			actual_args: ANY
		do
			fill_argument_array (args)
			actual_args := argument_array.area
			formal_args := argument_types.area

			inspect
				return_type
			when T_boolean then
				imp_boolean_result := desc_call_dll32_boolean (function_handle, arguments_size, $actual_args)
			when T_character then
				imp_character_result := desc_call_dll32_character (function_handle, arguments_size, $actual_args)
			when T_double then
				imp_double_result := desc_call_dll32_double (function_handle, arguments_size, $actual_args)
			when T_integer then
				imp_integer_result := desc_call_dll32_integer (function_handle, arguments_size, $actual_args)
			when T_real then
				imp_real_result := desc_call_dll32_real (function_handle, arguments_size, $actual_args)
			when T_pointer then
				imp_pointer_result := desc_call_dll32_pointer (function_handle, arguments_size, $actual_args)
			when T_reference then
				imp_reference_result := desc_call_dll32_reference (function_handle, arguments_size, $actual_args)
			when T_short_integer then
				imp_integer_result := desc_call_dll32_short_integer (function_handle, arguments_size, $actual_args)
			when T_string then
				create imp_string_result.make_from_c (desc_call_dll32_string (function_handle, arguments_size, $actual_args))
			when T_no_type then
				desc_call_dll32_procedure (function_handle, arguments_size, $actual_args)
			end
			routine_called := True
		end

feature -- Status report

	boolean_result: BOOLEAN
			-- Value when the routine returns a boolean
		do
			Result := imp_boolean_result
		end

	character_result: CHARACTER
			-- Value when the routine returns a character
		do
			Result := imp_character_result
		end

	double_result: DOUBLE
			-- Value when the routine returns a double
		do
			Result := imp_double_result
		end

	integer_result: INTEGER
			-- Value when the routine returns an integer
		do
			Result := imp_integer_result
		end

	pointer_result: POINTER
			-- Value when the routine returns a pointer
		do
			Result := imp_pointer_result
		end

	real_result: REAL
			-- Value when the routine returns a real
		do
			Result := imp_real_result
		end

	reference_result: ANY
			-- Value when the routine returns a reference
		do
			Result := imp_reference_result
		end

	string_result: STRING
			-- Value when the routine returns a string
		do
			Result := imp_string_result
		end

feature -- Access

	library_index: INTEGER
			-- Index of the routine in `shared_library'

	shared_library: DLL_32
			-- Associated library for the routine

feature {NONE} -- Implementation

	argument_array: ARRAY [INTEGER]
			-- Values to be pushed on the C stack

	arguments_size: INTEGER

	fill_argument_array (args: ARRAY [ANY])
			-- Fill area for stack pushing operation
		local
			i, j, nb: INTEGER
			area: ANY
			position: INTEGER
			arg_type, arg_size: INTEGER
			b_ref: BOOLEAN_REF
			c_ref: CHARACTER_REF
			d_ref: DOUBLE_REF
			i_ref: INTEGER_REF
			r_ref: REAL_REF
			p_ref: POINTER_REF
			b: BOOLEAN
			c: CHARACTER
			d: DOUBLE
			int: INTEGER
			r: REAL
			p: POINTER
			a: ANY
			s: STRING
			s1: ARRAY [INTEGER]
			s2: ARRAY [REAL]
			s3: ARRAY [DOUBLE]
			s4: ARRAY [BOOLEAN]
			s5: ARRAY [CHARACTER]
			s6: ARRAY [POINTER]
			s7: ARRAY [ANY]
			array_area: ANY
			l_data: POINTER
		do
			from
				i := args.lower
				j := argument_types.lower
				nb := argument_count
				area := argument_array.area
			until
				i > nb
			loop
				arg_type := argument_types @ j
				arg_size := desc_get_size (arg_type)
				inspect
					arg_type
				when T_array then
					s1 ?= args @ i
					if s1 = Void then
						s2 ?= args @ i
						if s2 = Void then
							s3 ?= args @ i
							if s3 = Void then
								s4 ?= args @ i
								if s4 = Void then
									s5 ?= args @ i
									if s5 = Void then
										s6 ?= args @ i
										if s6 = Void then
											s7 ?= args @ i
											array_area := s7.area
										else
											array_area := s6.area
										end
									else
										array_area := s5.area
									end
								else
									array_area := s4.area
								end
							else
								array_area := s3.area
							end
						else
							array_area := s2.area
						end
					else
						array_area := s1.area
					end
					l_data := $array_area
					desc_copy_arg ($area, $l_data, position * 4, arg_size)
				when T_boolean then
					b_ref ?= args @ i
					b := b_ref.item
					if b then
						argument_array.put (1, position + 1)
					else
						argument_array.put (0, position + 1)
					end
				when T_character then
					c_ref ?= args @ i
					c := c_ref.item
					argument_array.put (c_ref.code, position + 1)
				when T_double then
					d_ref ?= args @ i
					d := d_ref.item
					desc_copy_arg ($area, $d, position * 4, arg_size)
					position := position + 1
				when T_integer, T_short_integer then
					i_ref ?= args @ i
					int := i_ref.item
					argument_array.put (int, position + 1)
				when T_real then
					r_ref ?= args @ i
					r := r_ref.item
					desc_copy_arg ($area, $r, position * 4, arg_size)
				when T_pointer then
					p_ref ?= args @ i
					p := p_ref.item
					desc_copy_arg ($area, $p, position * 4, arg_size)
				when T_reference then
					a := args @ i
					l_data := $a
					desc_copy_arg ($area, $l_data, position * 4, arg_size)
				when T_string then
					s ?= args @ i
					a := s.to_c
					l_data := $a
					desc_copy_arg ($area, $l_data, position * 4, arg_size)
				end
				i := i + 1
				j := j + 1
				position := position + 1
			end
		end

	function_handle: POINTER
			-- Pointer to the external routine

	imp_boolean_result: BOOLEAN
			-- Value when the routine returns a boolean

	imp_character_result: CHARACTER
			-- Value when the routine returns a character

	imp_double_result: DOUBLE
			-- Value when the routine returns a double

	imp_integer_result: INTEGER
			-- Value when the routine returns an integer

	imp_pointer_result: POINTER
			-- Value when the routine returns a pointer

	imp_real_result: REAL
			-- Value when the routine returns a real

	imp_reference_result: ANY
			-- Value when the routine returns a reference

	imp_string_result: STRING
			-- Value when the routine returns a string

	make_argument_array
			-- Allocates area for stack pushing operation
		local
			i, nb: INTEGER
			size: INTEGER
		do
				-- This needs to be done at creation time, since no
				-- allocation is allowed between the call to `call' and
				-- the real call (if the area of a STRING is passed as a
				-- C string, it has to be valid, i.e. not move).
			from
				i := argument_types.lower
				nb := argument_types.upper
			until
				i > nb
			loop
				size := size + desc_get_size (argument_types @ i)
				i := i + 1
			end
			create argument_array.make (1, size // 4)
			arguments_size := size // 4
		end

feature {NONE} -- Externals

	desc_call_dll32_boolean (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): BOOLEAN
			-- Call to function returning a boolean
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_BOOLEAN"
		end

	desc_call_dll32_character (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): CHARACTER
			-- Call to function returning a character
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_CHARACTER"
		end

	desc_call_dll32_double (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): DOUBLE
			-- Call to function returning a double
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_DOUBLE"
		end

	desc_call_dll32_integer (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): INTEGER
			-- Call to function returning an integer
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_INTEGER"
		end

	desc_call_dll32_pointer (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): POINTER
			-- Call to function returning a pointer
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_POINTER"
		end

	desc_call_dll32_real (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): REAL
			-- Call to function returning a real
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_REAL"
		end

	desc_call_dll32_reference (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): ANY
			-- Call to function returning a reference
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_REFERENCE"
		end

	desc_call_dll32_procedure (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER)
			-- Call to procedure
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *)"
		end

	desc_call_dll32_short_integer (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): INTEGER
			-- Call to function returning a short integer
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): short int"
		end

	desc_call_dll32_string (f_ptr: POINTER; arg_count: INTEGER; actual_args: POINTER): POINTER
			-- Call to function returning a string
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD, char *): EIF_POINTER"
		end

	desc_copy_arg (target, source: POINTER; offset, size: INTEGER)
			-- Copy `size' characters from `source'
			-- to `target' + `offset'
		do
			(target + offset).memory_copy (source, size)
		end

	desc_get_function_index_pointer (m_p: POINTER; r_index: INTEGER): POINTER
			-- Get function handle (by index)
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD, DWORD): EIF_POINTER"
		end

	desc_get_size (type: INTEGER): INTEGER
			-- Get size of type `type'
		external
			"C [dll32 %"ise_desc.dll%"] (DWORD): short int"
		end

	win_get_proc_address (m_p, fn: POINTER): POINTER
			-- Get function handle
		external
			"C [macro <windows.h>] (HINSTANCE, LPCSTR): EIF_POINTER"
		alias
			"GetProcAddress"
		end

note
	copyright:	"Copyright (c) 1984-2006, Eiffel Software and others"
	license:	"Eiffel Forum License v2 (see http://www.eiffel.com/licensing/forum.txt)"
	source: "[
			 Eiffel Software
			 356 Storke Road, Goleta, CA 93117 USA
			 Telephone 805-685-1006, Fax 805-685-6869
			 Website http://www.eiffel.com
			 Customer support http://support.eiffel.com
		]"





end -- class DLL_32_ROUTINE