module DynamicLinker

import StdString, StdArray, StdEnum;
from ArgEnv import getCommandLine;

from ExtFile import ExtractPathAndFile, ExtractPathFileAndExtension;
from ExtString import starts, ends, CharIndex;
import PmDynamic;
from DynamicLink import ReceiveReq, KillClient, StartProcess, FirstInstanceOfServer;
from WriteOptionsFile import write_options_file;
from ReadState import ReadState;

import ObjectToMem, SymbolTable, State, PmProject;

import DebugUtilities;
import states;

// Overleggen met Diederik
ApplicationOptionsToFlags :: !ApplicationOptions -> Int;
ApplicationOptionsToFlags {sgc,pss,marking_collection,set,o,memoryProfiling,write_stderr_to_file}
	= flags
	where
		flags					= showgc+printstacksize+showexectime+cons+marking_collection_mask+memory_profiling_mask+write_stderr_to_file_mask;
		showgc					| sgc = 2; = 0;
		printstacksize			| pss = 4; = 0;
		showexectime 			| set = 8; = 0;
		write_stderr_to_file_mask
								| write_stderr_to_file = 128; = 0;
		marking_collection_mask | marking_collection = 64 ; = 0;
		memory_profiling_mask	| memoryProfiling = 32 ; = 0;
		cons					| o == BasicValuesOnly	= 1; | o == ShowConstructors = 0; = 16;

// shared with mac
/*
:: *States :== [(!Int,*State)]

AddState :: !Int !*State !*States -> !*States
AddState id state states
	= [(id,state)] ++ states
		
RemoveState :: !Int !*States -> (!Bool,!*State,!*States)
RemoveState id []
	= (False, EmptyState, [])
RemoveState id [s:ss]
	| (fst s) == id
		= (True, snd s, ss)
	
		# (ok,state,states)
			= RemoveState id ss 
		= (ok,state,[s] ++ states)
*/

// -----------------------------------------------------------------------------------
:: MainLoopStatus = Init | Process | Quit

MainLoop :: !ServerState !MainLoopStatus !States [!String] !*Files -> ([!String],!*Files)
MainLoop  server_state Init states _ files
	#! commandline
		= getCommandLine;
	#! (application_path,_)
		= ExtractPathAndFile commandline.[0];
	#! server_state 
		= { server_state &
			application_path = application_path
		};
	#! (option,project_name)
		= case (size commandline) of {
			1 -> abort "MainLoop(Init): no project file";
			2 -> (commandline.[1],"");
			3 -> (commandline.[1],commandline.[2]);
		};
	#! server_state 
		= { server_state &
			static_application_as_client = (option == "/W") || (option  == "/w")
		};
	= MainLoop server_state Process states [] files;
		
MainLoop server_state=:{static_application_as_client} Process states _ files
	#! (client_id, request_name) 
		= ReceiveReq static_application_as_client
	#! server_state
		= { server_state &
			static_application_as_client = False
		}	
	#! requests
		= filter (\(name,_) -> (fst (starts name request_name))) RequestList;

	| F ("<" +++ request_name +++ ">") (length requests) == 1

		// extract arguments and execute request
		#! request_args
			= case (fst (starts "AddDescriptors" request_name)) of {
				False
					// arguments are separated by \n
					-> tl (ExtractArguments '\n' 0 request_name []);
				True
					//								   01234567890123
					// raw data follows directly after AddDescriptors
					#! index
						= 14;
					-> [request_name % (index, size request_name - 1)];
				};
		#! (remove_state, /*server_state*/ _ ,states,files)
			= F ("n_args: " +++ toString (length request_args)) (snd (hd requests)) client_id request_args server_state states files

		// check for errors
		#! (_,state,states)
			= RemoveState client_id states;
		# (messages,state)
			= st_getLinkerMessages state;		
		#! (ok,state)
			= st_isLinkerErrorOccured state;
		| FL (messages) not ok
			= abort "DynamicLinker(PROCESS): stopped because of error";
			
		// remove state if necessary
		#! states
			= case remove_state of {
				True
					-> states;
				False
					-> AddState client_id state states;
			};
		= MainLoop server_state (if (request_name == "Quit\n") Quit Process) states [] files;
	
		// unrecognised request	
		= abort ("MainLoop: length requests <> 1 - " +++ toString (length requests));
where
	RequestList 
		= [
			("AddClient",AddClientRequest)
		,	("AddLabel",AddLabelRequest)
		,	("Init",InitRequest)
		,	("Quit",QuitRequest)
		,	("Close",CloseRequest)
		,	("AddAndInit",AddAndInitRequest)
 		,	("AddDescriptors",AddDescriptorsRequest)
		 ]

MainLoop _ Quit states errors files 
	= (errors,files)

AddDescriptorsRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
AddDescriptorsRequest client_id [string_table] server_state states files
	| F "AddDescriptorsRequest" True
	#! unknown_modules_or_symbols
		= (convert_to_symbolic_function_pointers (get_names 0 string_table []) [])

	// check if client exists
	#! (ok, state=:{dynamic_linker_node={project}}, states) 
		= RemoveState client_id states;
	| not ok
		#! message
			= "AddDescriptorsRequest (internal error): client not registered";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);

	// link and load additional unknown modules and/or symbols
	#! (ok, addresses,server_state,state,files)
		= NewLinkerFunction unknown_modules_or_symbols server_state state files
	| not ok
		#! message
			= case (KillClient client_id) of {
				True 
					-> "AddDescriptorsRequest: error during linking";
				False
					-> "AddDescriptorsRequest (internal error): could not kill client";
			};	
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);

		= (False,server_state,AddState client_id state states,files)
where
	convert_to_symbolic_function_pointers :: [(!String,!String,!String)] ![!ModuleOrSymbolUnknown] -> ![!ModuleOrSymbolUnknown]
	convert_to_symbolic_function_pointers [] symbolic_function_pointers 
		= symbolic_function_pointers
		
	convert_to_symbolic_function_pointers [(descriptor_prefix,function_name,module_name):others] symbolic_function_pointers
		#! label_name
			= case module_name of
				/*
				** system functions e.g. INT, Cons, Nil are not at all prefixed with 
				** their defining module name _system.
				*/ 
				"_system"
					-> case function_name of
						/*
						** The descriptor names for objects of the standard environment are irregular.
						** They therefore need to be translated manually to the proper label names.
						*/
						"INT"
							-> "INT"
						"Cons"
							-> "__Cons"
						"Nil"
							-> "__Nil"
						"ARRAY"
							-> "ARRAY"
						"_ARRAY_"
							-> "__ARRAY__"
						"_STRING_"
							-> "__STRING__"
						"BOOL"
							-> "BOOL"
						"REAL"
							-> "REAL"
						"CHAR"
							-> "CHAR"
						"_Tuple"
							-> "__Tuple"
						_
							-> abort ("<convert_to_symbolic_function_pointers>: object not supported " +++ function_name +++ " - " +++ module_name)			
				_
					->  ("e__" +++ module_name +++ "__" +++ descriptor_prefix +++ function_name)
		= (convert_to_symbolic_function_pointers others (symbolic_function_pointers ++ [ModuleUnknown module_name label_name]))

	/*
	** get_names
	** This function delivers the names of both the function and its defining
	** module in the order of the stringtable.
	*/
	get_names :: !Int !String [(!String,!String,!String)] -> [(!String,!String,!String)]
	get_names i string_table strings
		
		| i == size string_table
			= strings
			
			#! l_function_name
				= FromStringToInt string_table i
				
			/*
			** Two most significant bits are reserved for the generation of 
			** label names:
			** 00 = generate 'd'-prefix
			** 01 = generate 'n'-prefix
			*/ 
			#! descriptor_prefix
				= case ( l_function_name >> 28) of
					1	->	"n"
					2	->	"k"
					3	-> 	"c"
					4	->	"t"
					5	->	"r"
					6	->	"d"
					_
						-> abort ("get_names: cannot generate prefix error" +++ (toString (l_function_name)))
			#! l_function_name
				= l_function_name bitand 0x0fffffff
			#! function_name_start
				= i + 4
			#! function_name
				= string_table % (function_name_start, function_name_start + l_function_name - 1)

			#! module_length_start
				= function_name_start + ((l_function_name + 3) / 4) * 4
			#! l_module_name
				= FromStringToInt string_table module_length_start
			| (l_module_name bitand 0x80000000) == 0
			 	/*
			 	** The signed bit of module length is not set, then the module name
			 	** follows the function. no indirection has to be taken.
			 	*/
			 	#! module_name_start 
			 		= module_length_start + 4
			 	#! module_name
			 		= string_table % (module_name_start, module_name_start + l_module_name - 1)
			 	= get_names (module_name_start + ((l_module_name + 3) / 4) * 4) string_table (strings ++ [(descriptor_prefix,function_name,module_name)]) 
			 		
				/*
				** length of module name was negative, which means it is a
				** relative offset from that length in the string to the 
				** proper module name.
				*/
				#! module_length_start_indirection
					= module_length_start + l_module_name - 4
				#! l_module_name
					= FromStringToInt string_table module_length_start_indirection
				#! module_name_start
					= module_length_start_indirection + 4
				#! module_name
					= string_table % (module_name_start, module_name_start + l_module_name - 1)
				= get_names (module_length_start + 4) string_table (strings ++ [(descriptor_prefix,function_name,module_name)]) 
			 		
	print_names []
		= ""
	print_names [(s1,s2):ss]
		= (s1 +++ " " +++ s2 +++ "\n") +++ (print_names ss)
			
	FromStringToInt :: !String !Int -> !Int
	FromStringToInt array i
		= (toInt v0)+(toInt v1<<8)+(toInt v2<<16)+(toInt v3<<24)
	where
		v0
			= array.[i]
		v1
			= array.[i+1]
		v2 
			= array.[i+2]
		v3  
			= array.[i+3]
			
ParseCommandLine :: !String -> {#{#Char}}
ParseCommandLine s
	# command_line
		= parse_command_line s 0 [];
	= { s \\ s <- command_line };
where
	parse_command_line :: String Int [{#Char}] -> ![{#Char}]
	parse_command_line s i l
		| i == (size s) 
			= l
			| not (s.[i] == '\"')
				// not found, no " then search for space
				#! (_,index)
					= CharIndex s i ' '
				= parse_command_line s (skip_spaces s index) (l ++ [s % (i,index-1)])
	
				#! (found,index)
					= CharIndex s (i+1) '\"'
				| found
					= parse_command_line s (skip_spaces s (index+1)) (l ++ [s % (i+1,index-1)])
					
					= abort "parse_command_line: an error"
		
	skip_spaces :: String Int -> Int
	skip_spaces s i
		| (size s) == i
			= size s
			| s.[i] == ' '
				= skip_spaces s (inc i)		
				= i

AddClientRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
AddClientRequest client_id [cmdline] server_state=:{application_path} states files
	// default
	#! state
		= EmptyState;
		
	// check for configuration
	| (option <> "") && (not (option == "/s" || option == "/S"))
		#! message
			= "AddClientRequest (internal error): configuration does no longer exist";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
		
	// read projectfile to start client
	| not ((ends project_name ".prj") ||  (ends project_name ".PRJ"))
		#! message
			= "AddClientRequest (internal error): no project called " +++ project_name;
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
	#! ((project,ok,error),files)
		= ReadProjectFile project_name application_path files;
	#! (project_static_info,project)
		= getStaticInfo project;
	#! projectdir
		= project_static_info.stat_prj_path;
	#! dynamic_linker_node 
		= { EmptyDynamicLinkerNode &
			project	= project,
			project_name = project_name
		};
	#! state
		= { EmptyState &
			dynamic_linker_node = dynamic_linker_node
		};
	#! is_console_client
		= ((PR_GetApplicationOptions project).o <> NoConsole)
	#! client_executable
		= application_path +++ (if is_console_client 
			"\\ConsoleClient.exe" "\\GuiClient.exe");
	#! (application_name,project)
		= (PR_GetRootModuleName project);
	
	#! (client_started,client_id,new_application_path)
		= StartProcess is_console_client client_executable application_name client_executable;
	|  not client_started
		#! message
			= "client " +++ application_name +++ " could not be started";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
		= (False,server_state,AddState client_id state states,files);
where
	parsed_command_line
		= ParseCommandLine cmdline;
		
	(option,project_name)
		= case (size parsed_command_line) of {
			2	-> ("",parsed_command_line.[1]);
			3	-> (parsed_command_line.[1],parsed_command_line.[2]);
		};
		
InitRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
InitRequest client_id _ server_state=:{application_path} states files	
	// check if client exists
	#! (ok, state=:{dynamic_linker_node={project}}, states) 
		= RemoveState client_id states;
	| not ok
		#! message
			= "InitRequest (internal error): client not registered";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
		
	// generate _<application_name>_options.o
	#! application_options
		= PR_GetApplicationOptions project;
	#! {hs=heap_size,ss=stack_size,initial_heap_size,heap_size_multiple,memoryProfilingMinimumHeapSize=min_write_heap_size,sgc,pss,marking_collection,set,o,memoryProfiling,write_stderr_to_file}
		= application_options;
	#! flags
		= ApplicationOptionsToFlags application_options;
	#! options_file_name
		= application_path +++ "\\" +++ "_options.o";
	#! (ok, files)
		= write_options_file options_file_name flags heap_size stack_size initial_heap_size heap_size_multiple min_write_heap_size files;
		
	#! (ok,a,server_state1,state,files)
		= InitialLink [ "", "_mainCRTStartup"] server_state state files;
	| not ok
		#! message
			= case (KillClient client_id) of {
				True 
					-> "AddDescriptorsRequest: error during linking";
				False
					-> "AddDescriptorsRequest (internal error): could not kill client";
			};	
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);

	= (False,server_state,AddState client_id state states,files)

AddLabelRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
AddLabelRequest client_id /*request_args*/ [module_name,symbol_name] server_state states files
	| F "AddLabelRequest" True
	// check if client exists
	#! (ok, state=:{dynamic_linker_node={project_name}}, states)
		= RemoveState client_id states
	| not ok
		#! message
			= "InitRequest (internal error): client not registered";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);

	#! (_,_,server_state,state,files)
		= NewLinkerFunction [ModuleUnknown module_name symbol_name] server_state state files;

	| not ok
		#! message
			= case (KillClient client_id) of {
				True 
					-> "AddLabelRequest: error during linking";
				False
					-> "AddLabelRequest (internal error): could not kill client";
			};	
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
	
		= (False,server_state,AddState client_id state states,files)


CloseRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
CloseRequest client_id _ server_state=:{application_path} states files
	// check if client exists
	#! (ok, state=:{dynamic_linker_node={updated,project,project_name}}, states)
		= RemoveState client_id states
	| not ok
		#! message
			= "InitRequest (internal error): client not registered";
		= (True,server_state,AddState client_id (st_addLinkerMessage (LinkerError message) state) states,files);
		
	// save project file if necessary
	#! files
		= case updated of {
			True
				#! (ok,files)
					= SaveProjectFile project_name project application_path files;
				| not ok
					-> abort ("CloseRequest: error during closing of client  '" +++ project_name +++ "'");
				-> files;
			False
				-> files;
		};
	= (True,server_state,AddState client_id EmptyState states,files);
where
	isEmpty :: !States -> (!Bool,!States)
	isEmpty [] 
		= (True, [])
	isEmpty states
		= (False,states)
		
/*
	AddAndInitRequest
	
	Purpose:
	This request is (automatically) sent by an eagerly linked client which is eager linked. The message is
	only sent because execution of the client cannot proceed without the requested object. The dynamic linker
	returns the address of the object.
*/
AddAndInitRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files)
AddAndInitRequest client_id [commandline] server_state=:{application_path} states files
	// fill linker data structures by reading the complement
	#! (name_without_extension,_)
		= ExtractPathFileAndExtension parsed_command_line.[0];
	#! (state,files) 
		= ReadState parsed_command_line.[0] files;
	#! (ok,state)
		= st_isLinkerErrorOccured state;
	| not ok
		= (True,server_state,AddState client_id state states,files);

	// (pc) remove static client library
	#! state
		= RemoveStaticClientLibrary state;

	// try to read the project which contains additional information
	#! project_name 
		= name_without_extension +++ ".prj";		
	#! ((project,ok,error),files)
		= ReadProjectFile project_name application_path files;
	#! (updated,projectdir,project) 
		= case ok of
			True
				// read project
				#! (project_static_info,project)
					= getStaticInfo project;
				#! projectdir 
					= project_static_info.stat_prj_path;
				-> (False,projectdir,project);
			False
				// project could not be read; create a default one
				#! project 
					= PR_InitProject;
				#! (project_static_info,project)
					= getStaticInfo project;
				#! project_dir
					= fst (ExtractPathAndFile name_without_extension);
				#! project_static_info
					= { project_static_info &
					   stat_prj_path = project_dir
					  };
				#! project 
					= setStaticInfo project_static_info project;
				-> (True,project_dir,project);
	
	#! dynamic_linker_node 
		= { state.dynamic_linker_node &
			updated = updated,
			project	= project,
			project_name = project_name
		};
	#! state
		= { state &
			dynamic_linker_node = dynamic_linker_node
		};			
	= (False,server_state,AddState client_id state states,files);
where
	parsed_command_line
		= ParseCommandLine commandline;	
		
	RemoveStaticClientLibrary :: !*State -> !*State;
	RemoveStaticClientLibrary state=:{n_libraries,library_list}
		#! (n_libraries,library_list)
			= remove_static_client_library library_list n_libraries
		= { state &
			n_libraries = n_libraries,
			library_list = library_list
		};
	where
	
		remove_static_client_library EmptyLibraryList n_libraries
			= (n_libraries,EmptyLibraryList);
		remove_static_client_library (Library library_name i0 i1 i2 librarylists) n_libraries
			| library_name == "StaticClientChannel.dll"
				= remove_static_client_library librarylists (dec n_libraries);
				#! (n_libraries,librarylists)
					= remove_static_client_library librarylists n_libraries;
				= (n_libraries,Library library_name i0 i1 i2 librarylists);

		
	pr EmptyLibraryList
		= "";
	pr (Library library_name i0 i1 i2 librarylists)
		= library_name +++ "!\n" +++ (pr librarylists);


QuitRequest :: !Int [!String] !ServerState !States !*Files -> (!Bool,!ServerState,!States,!*Files);
QuitRequest client_id _ server_state states files
	= (True,server_state,AddState client_id EmptyState states,files)
		
		
Start world
	= (accFiles (f []) world)
where	
	f targets files
		| FirstInstanceOfServer			
			#! (errors,files) 
				= MainLoop EmptyServerState Init [] [] files
			= (errors,files)
			
			// not first instance
			= (["not first instance"], files)

ExtractArguments :: !Char !Int !String [!String] -> [!String];
ExtractArguments sep i request args
	| size request == i
		= args;
		| (request.[i]) == sep
			= args;
		
			#! (found, index)
				= CharIndex request i sep;
			| found
				= ExtractArguments sep (inc index) request (args ++ [request % (i,index-1)]);
				= abort ("ExtractArguments: separator not found:" +++ request);