PmCleanSystem.icl 43.8 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1 2 3
implementation module PmCleanSystem

import StdArray, StdBool, StdChar, StdFunc, StdInt, StdList, StdEnum
4
import StdMaybe
Camil Staps's avatar
Camil Staps committed
5
from StdMisc import abort, undef
Diederik van Arkel's avatar
Diederik van Arkel committed
6

7 8
from Platform import DirSeparator,DirSeparatorString

Diederik van Arkel's avatar
Diederik van Arkel committed
9 10 11 12
import Directory

import PmCompilerOptions, UtilStrictLists
import PmPath
13 14
import PmCallBack

Diederik van Arkel's avatar
Diederik van Arkel committed
15 16 17 18
import UtilNewlinesFile
import WriteOptionsFile

from PmParse import IsTypeSpec, IsImportError13, IsImportError20
19
from linkargs import ReadLinkErrors,WriteLinkOpts,:: LinkInfo`(..),:: LPathname
Diederik van Arkel's avatar
Diederik van Arkel committed
20 21 22 23 24
import thread_message
import lib

import UtilIO

Diederik van Arkel's avatar
Diederik van Arkel committed
25
from Platform import TempDir
26 27 28

:: OSToolbox:==Int

29
tooltempdir =: TempDir
Diederik van Arkel's avatar
Diederik van Arkel committed
30 31 32

//--

Diederik van Arkel's avatar
Diederik van Arkel committed
33
// kernel_library is required by the _system _startup combo and should be encoded there
34 35
standardStaticLibraries :: !Processor !LinkMethod -> List String
standardStaticLibraries _ method
Diederik van Arkel's avatar
Diederik van Arkel committed
36
	= case method of
Diederik van Arkel's avatar
Diederik van Arkel committed
37 38 39
		LM_Static	-> ("kernel_library" :! morelibs)
		LM_Dynamic	-> ("kernel_library" :! "StaticClientChannel_library" :! morelibs)
/*
Diederik van Arkel's avatar
Diederik van Arkel committed
40 41
		LM_Eager	-> ("kernel_library" :! "StaticClientChannel_library" :! Nil)
		LM_Dynamic	-> ("kernel_library" :! "ClientChannel_library" :! Nil)
Diederik van Arkel's avatar
Diederik van Arkel committed
42 43 44
*/
morelibs	// Note that these dependencies are introduced by StdEnv and should be encoded there.
	= "user_library" :! "gdi_library" :! "comdlg_library" :! Nil
Diederik van Arkel's avatar
Diederik van Arkel committed
45

46 47 48 49 50 51 52
standardObjectFiles :: !Bool !Bool !Processor !Bool -> List String
standardObjectFiles stack_traces profiling _ use_64_bit_processor
	#! startup1_file = if stack_traces "_startup1Trace.o"
					  (if profiling "_startup1Profile.o" "_startup1.o")
	| not use_64_bit_processor
		= ("_startup0.o" :! startup1_file :! "_startup2.o" :! "_system.o" :! Nil)
		= ("_startup0.o" :! startup1_file :! "_startup2.o" :! "_startup3.o" :! "_startup4.o" :! "_system.o" :! Nil)
Diederik van Arkel's avatar
Diederik van Arkel committed
53 54 55 56 57 58 59 60 61 62 63 64 65 66

//-- interface to static libraries...

getLibs :: ![String] !*Files -> (!(![String],![String]),!*Files)
getLibs [] files = (([],[]),files)
getLibs [lib:libs] files
	# (errs,slibs,files)		= getLib lib files
	# ((errs`,slibs`),files)	= getLibs libs files
	= ((errs++errs`,slibs++slibs`),files)
getLib lib files
	# (errs,slibs,files)	=  OpenArchive lib files
	# slibs					= map RemoveSuffix slibs
	= (errs,slibs,files)

67 68 69 70 71 72 73
:: CompilerProcessHandlesAndId = {
	compiler_thread_id :: !Int,
	compiler_thread_handle :: !Int,
	compiler_process_handle :: !Int
   }

:: CompilerProcessIds :== [CompilerProcessHandlesAndId]
Diederik van Arkel's avatar
Diederik van Arkel committed
74

75 76
NoCompilerProcessIds :: CompilerProcessIds
NoCompilerProcessIds = []
Diederik van Arkel's avatar
Diederik van Arkel committed
77

78 79
ClearCompilerCache :: !String !String !.a -> (!Int,!.a)
ClearCompilerCache _ _ ps = (0,ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
80

81 82 83
ClearCompilerCaches :: !CompilerProcessIds !.a -> (!Int,!.a)
ClearCompilerCaches _ ps = (0,ps)

84
QuitCleanCompiler :: !Bool !CompilerProcessIds !*World -> *World
85 86 87 88 89 90 91 92 93 94 95 96
QuitCleanCompiler async compiler_process_ids io
	| async
		= quit_compilers compiler_process_ids io;
		with
			quit_compilers [{compiler_thread_id,compiler_process_handle}:compiler_process_ids] io
				# wm_number=get_message_number;
				# r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("exit\0")
				| r==r
					= quit_compilers compiler_process_ids io;
			quit_compilers [] io
				= io;
	= io;
Diederik van Arkel's avatar
Diederik van Arkel committed
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113

ExitCleanCompiler :: !*(!*CompilingInfo,*env) -> *(!*CompilingInfo,*env)
ExitCleanCompiler prog=:(CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle), ps)
	# wm_number=get_message_number;
	# r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("exit\0")
	| /*trace_tn ("ExitCleanCompiler "+++toString r+++"\n") &&*/ r==0
		= prog
		= (CompilingInfo NoCompiler,ps);
ExitCleanCompiler prog
	= prog

//--

::	CodeGenerateAsmOrCode	= AsmGeneration	| CodeGeneration

instance == CodeGenerateAsmOrCode
where
114
//	(==) :: !CodeGenerateAsmOrCode !CodeGenerateAsmOrCode -> Bool
Diederik van Arkel's avatar
Diederik van Arkel committed
115 116 117 118 119 120 121 122 123 124 125
	(==) AsmGeneration AsmGeneration
		=	True
	(==) CodeGeneration CodeGeneration
		=	True
	(==) _ _
		=	False

::	CompileOrCheckSyntax	= SyntaxCheck | Compilation

instance == CompileOrCheckSyntax
where
126
//	(==) :: !CompileOrCheckSyntax !CompileOrCheckSyntax -> Bool
Diederik van Arkel's avatar
Diederik van Arkel committed
127 128 129 130 131 132
	(==) SyntaxCheck SyntaxCheck
		=	True
	(==) Compilation Compilation
		=	True
	(==) _ _
		=	False
133
/*
Diederik van Arkel's avatar
Diederik van Arkel committed
134 135 136 137 138 139 140 141 142 143 144
::	CompileClearCache	= ClearCache | Don`tClearCache

instance == CompileClearCache
where
	(==) :: CompileClearCache CompileClearCache -> Bool
	(==) ClearCache ClearCache
		=	True
	(==) Don`tClearCache Don`tClearCache
		=	True
	(==) _ _
		=	False
145
*/
Diederik van Arkel's avatar
Diederik van Arkel committed
146 147 148 149 150 151 152 153 154 155 156 157
::	CompilerMsg
	= 	CompilerOK
	| 	SyntaxError
	| 	Patherror Pathname

instance == CompilerMsg
where
	(==) CompilerOK CompilerOK = True
	(==) SyntaxError SyntaxError = True
	(==) (Patherror _) (Patherror _) = True
	(==) _ _ = False
	
Diederik van Arkel's avatar
Diederik van Arkel committed
158
::	WindowFun env :== ([String]) -> env -> env
Diederik van Arkel's avatar
Diederik van Arkel committed
159 160 161

//-- Synchronous compilation stuff...

162 163 164 165 166
:: ProjectCompilerOptions = {
	pco_memory_profiling :: !Bool,
	pco_time_profiling :: !Bool,
	pco_desc_exl :: !Bool,
	pco_dynamics :: !Bool,
167
	pco_generic_fusion :: !Bool,
168 169 170
	pco_link_dynamic :: !Bool
   }

Diederik van Arkel's avatar
Diederik van Arkel committed
171
Compile ::
172
	!String !Bool !Bool !(WindowFun *env) !(WindowFun *env) !CompileOrCheckSyntax !ModuleDirAndName !Pathname
173
	!(List Pathname) !ProjectCompilerOptions !CompilerOptions !Pathname !CompilerProcessIds !*env
174
	-> (!Pathname,!CompilerMsg,!CompilerProcessIds,!*env)
Diederik van Arkel's avatar
Diederik van Arkel committed
175 176
	| FileEnv env
Compile
177 178
	cocl` use_compiler_process_ids write_module_times errwin typewin compileOrCheckSyntax mdn path paths project_compiler_options
	co=:{CompilerOptions | listTypes} startupdir compiler_process_ids ps
179
	# (cocl_ok,cocl,cocldir)	= mangleCompiler cocl` startupdir	// platform dependant mangling...
Diederik van Arkel's avatar
Diederik van Arkel committed
180 181
	| not cocl_ok
		# ps					= errwin [cocl] ps
182
		= ("",SyntaxError,compiler_process_ids,ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
183 184
	#	out_file_name		= out_file_path tooltempdir dummy_slot
		errors_file_name	= errors_file_path tooltempdir dummy_slot
185 186
	#	command = cocl +++ write_module_times_string +++
					CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax path paths project_compiler_options co
187
		(didit, exitcode, os4) = call_process_with_directory command cocldir 99
Diederik van Arkel's avatar
Diederik van Arkel committed
188 189
	    diditall               = if (os4 == 99) didit didit
	| not diditall
190
		# ps	= errwin (["Error: Unable to run compiler: "+++cocl +++ " :"+++toString exitcode]) ps
191
		= ("",SyntaxError,compiler_process_ids,ps)
192
	# (path,mess,env) =	CompileHandleExitCode exitcode cocl tooltempdir dummy_slot errwin typewin mdn listTypes ps
193
	= (path,mess,compiler_process_ids,env)
Diederik van Arkel's avatar
Diederik van Arkel committed
194 195 196 197 198
where
	dummy_slot = 0
	write_module_times_string = if write_module_times " -wmt " " "

mangleCompiler ccstring` startupdir
Diederik van Arkel's avatar
Diederik van Arkel committed
199 200
	# (ccstring`,rem)			= splitOptions ccstring`
	# (opts,opts`)				= splitOptions rem
Diederik van Arkel's avatar
Diederik van Arkel committed
201 202 203
	# (shortOK,ccstring)		= GetShortPathName (startupdir +++ "\\" +++ ccstring` +++ "\0")
	| not shortOK
		# line				= "Error: Unable to get short path name '" +++ (startupdir +++ "\\" +++ ccstring`) +++ "'."
Diederik van Arkel's avatar
Diederik van Arkel committed
204 205 206 207
		= (False,line,"")
	# cocl = ccstring % (0, size ccstring - 2) +++. opts +++. opts`
	# cocldir = RemoveFilename (ccstring % (0, size ccstring - 2))
	= (True,cocl,cocldir)
Diederik van Arkel's avatar
Diederik van Arkel committed
208 209

mangleCompiler2 ccstring` startupdir
Diederik van Arkel's avatar
Diederik van Arkel committed
210 211
	# (ccstring`,rem)			= splitOptions ccstring`
	# (opts,opts`)				= splitOptions rem
Diederik van Arkel's avatar
Diederik van Arkel committed
212 213 214
	# (shortOK,ccstring)		= GetShortPathName (startupdir +++ "\\" +++ ccstring` +++ "\0")
	| not shortOK
		# line				= "Error: Unable to get short path name '" +++ (startupdir +++ "\\" +++ ccstring`) +++ "'."
Diederik van Arkel's avatar
Diederik van Arkel committed
215 216 217 218
		= (False,line,"","","")
	# cocl = ccstring % (0, size ccstring - 2)
	# cocldir = RemoveFilename cocl
	= (True,cocl,cocldir,opts,opts`)
Diederik van Arkel's avatar
Diederik van Arkel committed
219 220 221 222 223 224 225 226

//-- Asynchronous compilation stuff...

:: ThreadId
	:==	Int
:: ExitCode
	:== Int

227
CompileStartCommand :: !String !Bool !(WindowFun *env) !CompileOrCheckSyntax !Pathname !(List Pathname) !Int !ProjectCompilerOptions
228 229
						!CompilerOptions !Pathname !CompilerProcessIds !*env
										 -> (!Bool,!CompilerProcessIds,!*env) | FileEnv env
230
CompileStartCommand cocl` write_module_times errwin compileOrCheckSyntax path paths slot project_compiler_options
231 232 233 234 235 236 237 238 239
					co startupdir compiler_process_ids ps
	# (cocl_ok,cocl,cocl_dir,cocl_startup,options)	= mangleCompiler2 cocl` startupdir	// platform dependant mangling...
	| not cocl_ok
		# ps = errwin [cocl] ps
		= (False,compiler_process_ids,ps)
	# out_file_name		=  out_file_path tooltempdir slot
	# errors_file_name	=  errors_file_path tooltempdir slot
	# cocl_arguments
		= " -id " +++toString slot+++" "+++options +++ write_module_times_string +++. 
240
			CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax path paths project_compiler_options co
241 242 243 244 245 246 247
	# (compile_ok,compiler_process_ids,ps) = start_compile_with_cache cocl slot cocl_dir cocl_startup cocl_arguments compiler_process_ids ps;
	| not compile_ok
  		# ps = errwin ["Error: Unable to run compiler: "+++cocl] ps
  		= (False,compiler_process_ids,ps)
	= (True,compiler_process_ids,ps)
where
	write_module_times_string = if write_module_times " -wmt " " "
Diederik van Arkel's avatar
Diederik van Arkel committed
248

249 250 251 252 253
dispatch_null_message_hook :: Int;
dispatch_null_message_hook = code {
	pushLc dispatch_null_message_hook
}

254 255 256 257 258 259 260
start_compile_with_cache :: String Int String String String CompilerProcessIds *env -> (!Bool,!CompilerProcessIds,!*env)
start_compile_with_cache path slot directory startup_arguments arguments compiler_process_ids ps
	| slot<length compiler_process_ids
		# compiler_handles_and_id = compiler_process_ids !! slot
		= start_compile_with_cache2 path compiler_handles_and_id directory arguments compiler_process_ids ps
	# thread_id=get_current_thread_id;
	# begin_arguments=startup_arguments+++" -ide "+++int_to_hex thread_id;
261 262
	# (r,compiler_thread_id,compiler_thread_handle,compiler_process_handle)
		= start_compiler_process (IF_BATCHBUILD_OR_IDE 0 dispatch_null_message_hook) (path+++"\0") (directory+++"\0") ("\""+++path+++"\" "+++begin_arguments+++"\0");
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
	| r==0
		= (False,compiler_process_ids,ps)
	# compiler_handles_and_id = {compiler_thread_id=compiler_thread_id,compiler_thread_handle=compiler_thread_handle,compiler_process_handle=compiler_process_handle}
	# compiler_process_ids = compiler_process_ids++[compiler_handles_and_id]
	= start_compile_with_cache2 path compiler_handles_and_id directory arguments compiler_process_ids ps

start_compile_with_cache2 :: {#.Char} CompilerProcessHandlesAndId {#.Char} {#.Char} CompilerProcessIds *env -> (!Bool,!CompilerProcessIds,!*env)
start_compile_with_cache2 path {compiler_thread_id,compiler_thread_handle,compiler_process_handle} directory arguments compiler_process_ids ps
	# wm_number=get_message_number
	# r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("cocl "+++arguments+++"\0")
	| r==0
		= (False,compiler_process_ids,ps)
	= (True,compiler_process_ids,ps)

:: CompilePollCompletedResult = NoFinishedCompiler | UnknownFinishedCompiler | FinishedCompiler !Int !Int

279 280
CompilePollCompleted :: !CompilerProcessIds !*env -> (!CompilePollCompletedResult, !*env) | FileEnv env
CompilePollCompleted compiler_process_ids ps
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
	= IF_BATCHBUILD_OR_IDE

		(let
			wm_number=get_message_number
			(r,compiler_id,exit_code) = get_integers_from_message wm_number
		 in
		   if (r==0)
			(NoFinishedCompiler,ps)
			(FinishedCompiler compiler_id exit_code,ps))

		(let
			(compiler_id,exit_code) = get_finished_compiler_id_and_exit_code
		 in
		   if (compiler_id<0)
			(NoFinishedCompiler,ps)
			(FinishedCompiler compiler_id exit_code,ps));
297 298 299 300 301

get_finished_compiler_id_and_exit_code :: (!Int/*compiler_id*/,!Int/*exit_code*/);
get_finished_compiler_id_and_exit_code = code {
	ccall get_finished_compiler_id_and_exit_code ":II"
 }
Diederik van Arkel's avatar
Diederik van Arkel committed
302 303 304 305

//-- Persistent compilation stuff...synchronous for now...

CompilePersistent ::
306
	!String !Bool !(WindowFun *env) !(WindowFun *env) !CompileOrCheckSyntax !ModuleDirAndName
307
	!(List Pathname) !ProjectCompilerOptions !CompilerOptions !Pathname !*CompilingInfo !*env
Diederik van Arkel's avatar
Diederik van Arkel committed
308 309
	-> (!*CompilingInfo,!(!*env, !Pathname, !CompilerMsg))
	| FileEnv env
310 311
CompilePersistent cocl` write_module_times errwin typewin compileOrCheckSyntax mdn paths project_compiler_options
	co=:{CompilerOptions | listTypes} startupdir cstate env
Diederik van Arkel's avatar
Diederik van Arkel committed
312

Diederik van Arkel's avatar
Diederik van Arkel committed
313
	# (cocl_ok,cocl,cocl_dir,cocl_startup,options)	= mangleCompiler2 cocl` startupdir	// platform dependant mangling...
Diederik van Arkel's avatar
Diederik van Arkel committed
314 315 316 317 318 319 320
	| not cocl_ok
		# env					= errwin [cocl] env
		= (cstate,(env,"",SyntaxError))

	#	out_file_name		=  out_file_path tooltempdir dummy_slot
		errors_file_name	=  errors_file_path tooltempdir dummy_slot
	# cocl_arguments
321
		= options +++ write_module_times_string +++.
322
		  CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax mdn.mdn_name paths project_compiler_options co
Diederik van Arkel's avatar
Diederik van Arkel committed
323 324
//	# cstate = NotCompiling
//	# cocl = startupdir+++toString dirseparator +++"cocl.exe";
Diederik van Arkel's avatar
Diederik van Arkel committed
325
	# (compile_ok,exitcode,(cstate,env)) = compile_with_cache cocl cocl_dir cocl_startup cocl_arguments (cstate,env);
Diederik van Arkel's avatar
Diederik van Arkel committed
326
	| not compile_ok
327
  		# env = errwin ["Error: Unable to run compiler: "+++cocl +++ " :"+++toString exitcode] env
Diederik van Arkel's avatar
Diederik van Arkel committed
328
  		= (cstate,(env,"",SyntaxError))
329
	# (path,mess,env) = CompileHandleExitCode exitcode cocl tooltempdir dummy_slot  errwin typewin mdn listTypes env
Diederik van Arkel's avatar
Diederik van Arkel committed
330 331 332 333 334 335 336
	=	(cstate,(env,path,mess))
where
	dummy_slot = 0
	write_module_times_string = if write_module_times " -wmt " " "

//-- Generic Compilation stuff...

337 338
CompileBuildCommand :: !String !String !CompileOrCheckSyntax !Pathname !(List Pathname) !ProjectCompilerOptions !CompilerOptions -> String
CompileBuildCommand out_file_name errors_file_name compileOrCheckSyntax path paths project_compiler_options co
Diederik van Arkel's avatar
Diederik van Arkel committed
339 340
	= MakeCompilerOptionsString
		compileOrCheckSyntax
341
		project_compiler_options
Diederik van Arkel's avatar
Diederik van Arkel committed
342 343 344 345 346 347
		co
		+++ (quoted_string path)
        +++ " -P " +++ quoted_string (ConcatenatePath paths)
		+++ " -RE "+++ quoted_string errors_file_name
		+++ " -RO "+++ quoted_string out_file_name;

348
CompileHandleExitCode :: !Int !String !String !Int !(WindowFun *env) !(WindowFun *env) !ModuleDirAndName
349
				!ListTypes !*env -> (!Pathname,!CompilerMsg,!*env) | FileEnv env
350
CompileHandleExitCode exitcode cocl startupdir slot errwin typewin mdn listTypes ps
351 352
	#	out_file_name		=  out_file_path tooltempdir slot
		errors_file_name	=  errors_file_path tooltempdir slot
Diederik van Arkel's avatar
Diederik van Arkel committed
353 354 355 356
	#	((type_text_not_empty,type_text),ps)
			= accFiles (ReadTypesInfo (listTypes<>NoTypes) out_file_name) ps
		((errors,errors_and_messages_not_empty,errors_and_messages),ps)
			= accFiles (ReadErrorsAndWarnings errors_file_name) ps
357
	| exitcode <> 0 && not errors_and_messages_not_empty =	// werkt dit ook voor persistent versie?
358 359 360
		( ""
		, SyntaxError
		, errwin (	[  "Error: Compiler crashed: "+++cocl
Diederik van Arkel's avatar
Diederik van Arkel committed
361 362 363
					: if (errors == CompilerOK) ["Unable to open Errors file"] []
					]) ps
		)
364
	#	abcpath			= ModuleDirAndNameToABCSystemPathname mdn
Diederik van Arkel's avatar
Diederik van Arkel committed
365 366 367 368 369
		ps				= (if type_text_not_empty (typewin (StrictListToList type_text)) id) ps
		ps				= (if errors_and_messages_not_empty (errwin (StrictListToList errors_and_messages)) id) ps
		errors			= case exitcode of
							0	-> CompilerOK
							_	-> errors
370
     = (abcpath,errors,ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
371 372 373 374 375 376 377 378 379 380 381

out_file_path :: String Int -> String
out_file_path tooltempdir slot
	=	file_path tooltempdir "out" slot

errors_file_path :: String Int -> String
errors_file_path tooltempdir slot
	=	file_path tooltempdir "errors" slot

file_path :: String String Int -> String
file_path dir base_name slot
382
	=	dir +++ DirSeparatorString +++ base_name +++ (if (slot == 0) "" (toString slot))
Diederik van Arkel's avatar
Diederik van Arkel committed
383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465

ConcatenatePath :: (List Pathname) -> String
/* old version
ConcatenatePath Nil             = ""
ConcatenatePath (path :! rest ) = path +++ ";" +++ ConcatenatePath rest
*/
ConcatenatePath ss
	# s = createArray (sSize ss) ';'
	= sUpdate 0 s ss
where
	sSize Nil = 0
	sSize (string :! Nil) = size string
	sSize (string :! rest) = size string + 1 + sSize rest
	
	sUpdate i s Nil = s
	sUpdate i s (string :! Nil)
		# (_,s) = sU (size string) i 0 s string
		= s
	sUpdate i s (string :! rest)
		# (i,s) = sU (size string) i 0 s string
		# i = inc i
		= sUpdate i s rest
	
	sU l i j s h
		| j >= l = (i,s)
		# s = update s i h.[j]
		= sU l (inc i) (inc j) s h

ReadTypesInfo :: !Bool !Pathname !*Files -> ((!Bool,!(List String)),!*Files)
ReadTypesInfo readtypes	path env
	| not readtypes
		= ((False,Nil),env)
	#	(opened,file,env)			= fopen path FReadText env
	| not opened
		= ((False,Nil),env)
	#	(typelist,types_read,file`)	= ReadTypeMsg file
		(_,env)						= fclose file` env
	= ((types_read,typelist),env)
	

ReadTypeMsg :: !*File -> (!List String,!Bool,!*File)
ReadTypeMsg file
	#	(string,file)					= freadline file
		(eof,file)						= fend file
	| eof && IsTypeSpec string
		= (Strip string :! Nil,True,file)
	| eof
		= (Nil,False,file)
	#	(typeslist,types_read,file)	= ReadTypeMsg file
	= (Strip string :! typeslist,types_read,file)

Strip "" = ""
Strip s
	#! last = dec (size s)
	#! char = s.[last]
	| char == '\n' || char == '\r'
		= Strip (s % (0,dec last))
	= s

ReadErrorsAndWarnings :: !Pathname !*Files -> ((!CompilerMsg, !Bool, !(List String)), !*Files)
ReadErrorsAndWarnings path env
	#	(opened,file,env)	= fopen path FReadText env
	| not opened
		= ((CompilerOK,False,Nil),env)
	#	(errors,errors_and_warnings_read,errlist,file`) = ReadErrorAndWarningMessages file
		(_,env) = fclose file` env
	= ((errors,errors_and_warnings_read,errlist),env)
	
ReadErrorAndWarningMessages :: !*File -> (!CompilerMsg,!Bool,!List String,!*File)
ReadErrorAndWarningMessages file
	#!	(string, file1)					= freadline file
		(eof,file2)						= fend file1
		(is_import_error13,path13)		= IsImportError13 string
		(is_import_error20,path20)		= IsImportError20 string
	# (is_import_error,path) = case is_import_error13 of
			True	-> (is_import_error13,path13)
			_		-> (is_import_error20,path20)
	| eof
		#!	not_empty_or_newline 		= (size string)<>0 && string.[0]<>'\n'
		= (if is_import_error (Patherror path) SyntaxError,not_empty_or_newline,Strip string :! Nil,file2)
	#	(path_error,_,errlist,file3) = ReadErrorAndWarningMessages file2
	= (if is_import_error (Patherror path) path_error,True,Strip string:!errlist,file3)

466
MakeCompilerOptionsString :: !CompileOrCheckSyntax !ProjectCompilerOptions !CompilerOptions -> String
467 468 469
MakeCompilerOptionsString compileOrCheckSyntax
		{pco_memory_profiling,pco_time_profiling,pco_desc_exl,pco_generic_fusion,pco_dynamics,pco_link_dynamic}
		{neverMemoryProfile, neverTimeProfile,sa,gw,gc,listTypes,attr,reuseUniqueNodes,fusion}
470 471 472 473
	= (add_dynamics_option (add_fusion_option (add_exl_option
		(checksyntax +++ timeProfileSwitch +++ memoryProfileSwitch +++ strictness +++ warnings +++ comments +++listtypes+++show_attr+++reuse)
	   ))) +++" "
where
Diederik van Arkel's avatar
Diederik van Arkel committed
474
	memoryProfileSwitch
475
		| (not neverMemoryProfile && pco_memory_profiling) || pco_desc_exl || pco_link_dynamic
Diederik van Arkel's avatar
Diederik van Arkel committed
476 477 478
			= " -desc"
			= ""
	timeProfileSwitch
479
		| not neverTimeProfile && pco_time_profiling
Diederik van Arkel's avatar
Diederik van Arkel committed
480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513
			= " -pt"
			= ""
	strictness
		| sa
			= ""
			= " -sa"
	warnings
		| gw
			= ""
			= " -w"
	comments
		| gc
			= " -d"
			= ""
	listtypes
		| listTypes == InferredTypes
			= " -lt"
		| listTypes == AllTypes
			= " -lat"
		| listTypes == StrictExportTypes
			= " -lset"
			= ""
	show_attr
		| attr
			= ""
			= " -lattr"
	checksyntax
		| compileOrCheckSyntax == SyntaxCheck
			= " -c"
			= ""
	reuse
		| reuseUniqueNodes
			= " -ou"
			= ""
514
	add_exl_option s = if (pco_desc_exl || pco_link_dynamic) (s+++" -exl") s
515 516 517 518

	add_fusion_option s
		= case fusion of FusionOn -> s+++" -fusion"; FusionDefault | pco_generic_fusion -> s+++" -generic_fusion"; _ -> s

519
	add_dynamics_option s = if (pco_dynamics || pco_link_dynamic) (s+++" -dynamics") s
Diederik van Arkel's avatar
Diederik van Arkel committed
520 521 522

/* Generates code for the given file:
*/	
523
/*
Diederik van Arkel's avatar
Diederik van Arkel committed
524 525 526 527 528 529 530 531 532 533
watcom_quoted_string string = "\"" +++ escape_specials 0 string +++ "\""
where
	escape_specials i string
		| i>=size string
			= string
		| string.[i]=='\\'
			= escape_specials (i+2) (string % (0,i-1)+++"\\"+++string % (i,dec (size string)))
		| string.[i]=='"'
			= escape_specials (i+2) (string % (0,i-1)+++"\\"+++string % (i,dec (size string)))
			= escape_specials (inc i) string
534
*/
Diederik van Arkel's avatar
Diederik van Arkel committed
535

536
CodeGen	::	!String !Bool !(WindowFun *GeneralSt) !CodeGenerateAsmOrCode !Pathname !Pathname !Bool
537 538
			!CodeGenOptions !Processor !ApplicationOptions !Pathname !CompilerProcessIds !*GeneralSt
			-> (!Pathname,!Bool,!CompilerProcessIds,!*GeneralSt)
539
CodeGen cgen` used_compiler_process_ids wf genAsmOrCode abc_path obj_path timeprofile cgo tp ao startupdir compiler_process_ids ps
Diederik van Arkel's avatar
Diederik van Arkel committed
540
	# (cgen_ok,cgen,cgendir)		= mangleGenerator cgen` startupdir
Diederik van Arkel's avatar
Diederik van Arkel committed
541 542
	| not cgen_ok
		# ps				= wf [cgen] ps
543
		= ("",False,compiler_process_ids,ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
544

545
	#	path_without_suffix	= RemoveSuffix abc_path
546
		command				= cgen +++ MakeCodeGenOptionsString genAsmOrCode timeprofile cgo tp
547 548
//								+++ " " +++ (watcom_quoted_string path_without_suffix)
								+++ " " +++ (quoted_string path_without_suffix)
Diederik van Arkel's avatar
Diederik van Arkel committed
549

550
  		errorsfilename		= tooltempdir +++ DirSeparatorString +++ "errors"
551
		(didit,exit_code,_) = call_process_with_directory_and_redirected_std_error command cgendir errorsfilename 99
Diederik van Arkel's avatar
Diederik van Arkel committed
552
	| not didit
553 554
		= (obj_path,False,compiler_process_ids,wf [  "Error: Unable to run code generator: "+++cgen
													] ps)
555
	#	code_generator_failed_message = "Error: Code generator failed for '" +++ abc_path +++ "' with exit code: "+++toString exit_code
Diederik van Arkel's avatar
Diederik van Arkel committed
556
	#	((_, errors_not_empty, error_text),ps)	= accFiles (ReadErrorsAndWarnings errorsfilename) ps
557 558 559 560 561 562 563 564
		ps	= (if errors_not_empty 
				(if (exit_code <> 0)
					(wf (StrictListToList error_text++[code_generator_failed_message])) 
					(wf (StrictListToList error_text)))
				(if (exit_code <> 0)
					(wf [code_generator_failed_message,quoted_string path_without_suffix])
					id)
			  ) ps
565
	=  (obj_path,exit_code==0,compiler_process_ids,ps)
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593

:: StartedCodeGenerator = !{
	scg_thread_handle :: !Int,
	scg_std_error_handle :: !Int,
	scg_abc_path :: !{#Char},
	scg_path_without_suffix :: !{#Char},
	scg_errors_file_name :: !{#Char}
  }

start_code_generator ::	!String !(WindowFun *GeneralSt) !Pathname !Int !Bool !CodeGenOptions !Processor !Pathname !*GeneralSt
						-> (!Bool,!Int/*HANDLE*/,!StartedCodeGenerator,!*GeneralSt)
start_code_generator cgen` wf abc_path slot timeprofile cgo tp startupdir ps
	# (cgen_ok,cgen,cgendir) = mangleGenerator cgen` startupdir
	| not cgen_ok
		# ps = wf [cgen] ps
		# scg = {scg_thread_handle=0,scg_std_error_handle=0,scg_abc_path="",scg_path_without_suffix="",scg_errors_file_name=""}
		= (False,0,scg,ps)
	# path_without_suffix = RemoveSuffix abc_path
	  command = cgen +++ MakeCodeGenOptionsString CodeGeneration timeprofile cgo tp +++ " " +++ (quoted_string path_without_suffix)
	  errors_file_name = errors_file_path tooltempdir slot
	  (didit,process_handle,thread_handle,std_error_handle,_) = start_process_with_redirected_std_error command cgendir errors_file_name 99
	| not didit
		# scg = {scg_thread_handle=0,scg_std_error_handle=0,scg_abc_path="",scg_path_without_suffix="",scg_errors_file_name=""}
		= (False,0,scg,wf ["Error: Unable to run code generator: "+++cgen] ps)
		# scg = {scg_thread_handle=thread_handle,scg_std_error_handle=std_error_handle,
				 scg_abc_path=abc_path,scg_path_without_suffix=path_without_suffix,scg_errors_file_name=errors_file_name}
		= (True,process_handle,scg,ps)

594 595 596
finish_code_generator :: !Int/*HANDLE*/ !StartedCodeGenerator !Int !(WindowFun *GeneralSt) !*GeneralSt -> (!Bool,!*GeneralSt)
finish_code_generator process_handle {scg_thread_handle,scg_std_error_handle,scg_abc_path,scg_path_without_suffix,scg_errors_file_name} exit_code wf ps
	# os = finish_process_with_redirected_std_error process_handle scg_thread_handle scg_std_error_handle 99
597 598 599
	| os<>99
		= undef
	# ((_, errors_not_empty, error_text),ps) = accFiles (ReadErrorsAndWarnings scg_errors_file_name) ps
600
	  code_generator_failed_message = "Error: Code generator failed for '" +++ scg_abc_path +++ "' with exit code: "+++toString exit_code
601
	  ps = (if errors_not_empty 
602 603 604 605 606 607 608
				(if (exit_code <> 0)
					(wf (StrictListToList error_text ++ [code_generator_failed_message]))
					(wf (StrictListToList error_text)))
				(if (exit_code <> 0)
					(wf [code_generator_failed_message,quoted_string scg_path_without_suffix])
					id
				)
609 610 611
			 ) ps
	=  (exit_code==0,ps)

612
wait_for_finished_code_generator :: !{#Int} !*GeneralSt -> (!Int,!Int,!*GeneralSt);
613 614 615 616
wait_for_finished_code_generator handles ps
	# n_handles = size handles
	# (i,os) = WaitForMultipleObjects n_handles handles False INFINITE 99
	| i>=WAIT_OBJECT_0 && i<WAIT_OBJECT_0+n_handles
617 618 619 620 621
		# process_n = i-WAIT_OBJECT_0
		# (_,exit_code,os) = GetExitCodeProcess handles.[process_n] os
		| os<>99
			= undef
		= (process_n,exit_code,ps)
622
	| i>=WAIT_ABANDONED_0 && i<WAIT_ABANDONED_0+n_handles
623 624 625 626 627 628
		# process_n = i-WAIT_ABANDONED_0
		# (_,exit_code,os) = GetExitCodeProcess handles.[process_n] os
		| os<>99
			= undef
		= (process_n,exit_code,ps)
		= (-1,-1,ps)
629

Diederik van Arkel's avatar
Diederik van Arkel committed
630 631 632 633 634
mangleGenerator cgen` startupdir
	# (cgen`,opts)			= splitOptions cgen`
	# (shortOK,cgen)		= GetShortPathName (startupdir +++ "\\" +++ cgen` +++ "\0")
	| not shortOK
		# line				= "Error: Unable to get short path name '" +++ (startupdir +++ "\\" +++ cgen`) +++ "'."
Diederik van Arkel's avatar
Diederik van Arkel committed
635 636 637 638
		= (False,line,"")
	# cgencom = cgen % (0, size cgen - 2) +++ opts
	# cgendir = RemoveFilename (cgen % (0, size cgen - 2))
	= (True,cgencom,cgendir)
Diederik van Arkel's avatar
Diederik van Arkel committed
639

640
MakeCodeGenOptionsString genAsmOrCode timeprofile {ci,cs} tp
Diederik van Arkel's avatar
Diederik van Arkel committed
641 642 643 644 645 646 647 648 649 650 651
	= checkindex+++checkstack+++genasm
where
	checkindex	| ci = " -ci"; = ""
	checkstack	| cs = " -os"; = ""
	genasm		| genAsmOrCode == AsmGeneration
										= " -a"
										= ""
	
/* Links the given file:
*/

652
Link ::	!String !(WindowFun *GeneralSt) !Pathname !ApplicationOptions
653
		!Pathname !(List Pathname) !(List Pathname) !(List Pathname) !Bool !Bool !Bool !Bool !Bool !String
654 655
		!Bool !String !Pathname !String !Processor !Bool !*GeneralSt
		 -> (!*GeneralSt,!Bool)
Diederik van Arkel's avatar
Diederik van Arkel committed
656 657
Link linker` winfun path
		applicationOptions=:{ss,hs,initial_heap_size,profiling,heap_size_multiple,o,memoryProfilingMinimumHeapSize=minheap}
658
		optionspathname library_file_names object_file_names static_libraries static gen_relocs gen_symbol_table gen_linkmap
659
		link_resources resource_path gen_dll dll_syms startupdir dynlstr _ use_64_bit_processor ps
Diederik van Arkel's avatar
Diederik van Arkel committed
660
	# (ok,linker,linkerdir)				= mangleLinker linker` startupdir
Diederik van Arkel's avatar
Diederik van Arkel committed
661 662 663 664 665 666 667 668 669 670 671 672 673 674
	| not ok
		# ps					= winfun [linker] ps
		= (ps,False)
	# flags						= ApplicationOptionsToFlags applicationOptions
	# optdirpath				= RemoveFilename optionspathname
	# ((ok,pd_optdirpath),ps)	= pd_StringToPath optdirpath ps
	| not ok
		= (winfun ["Linker error: Unable to understand path: "+++optdirpath] ps,False)
	# ((err,_),ps)				= getDirectoryContents pd_optdirpath ps
	# (err,ps)					= case err of
		DoesntExist		-> createDirectory pd_optdirpath ps
		err  			-> (err,ps)
	| err <> NoDirError
		= (winfun ["Linker error: Unable to access or create: "+++optdirpath] ps,False)
675
	# (options_file_ok,ps)		= accFiles (write_options_file optionspathname flags hs ss initial_heap_size heap_size_multiple minheap use_64_bit_processor) ps
Diederik van Arkel's avatar
Diederik van Arkel committed
676 677 678 679 680 681 682 683
	| not options_file_ok
		= (winfun ["Linker error: Could not write the options object file: "+++optionspathname] ps,False)
	# linkopts =
		{ exe_path					= path
		, res_path					= resource_path
		, open_console				= o <> NoConsole
		, static_link				= static
		, gen_relocs				= gen_relocs
684
		, gen_symbol_table			= gen_symbol_table
Diederik van Arkel's avatar
Diederik van Arkel committed
685 686 687 688 689 690 691 692
		, gen_linkmap				= gen_linkmap
		, link_resources			= link_resources
		, object_paths				= optionspathname :! (RemoveDup object_file_names)
	  	, dynamic_libs				= RemoveDup library_file_names
	  	, static_libs				= RemoveDup static_libraries
	  	, stack_size				= ss
		, gen_dll					= gen_dll
		, dll_names					= dll_syms
693
		, dynamics_path				= startupdir +++. DirSeparatorString +++. dynlstr
694
		, lib_name_obj_path = MakeFullPathname tooltempdir "lib_name.o"
Diederik van Arkel's avatar
Diederik van Arkel committed
695 696 697 698 699 700 701 702 703
	  	}
	# linkoptspath					= MakeFullPathname tooltempdir "linkopts"
	# linkerrspath					= MakeFullPathname tooltempdir "linkerrs"
	# (err,ps)						= accFiles (WriteLinkOpts linkoptspath linkopts) ps
	| isJust err
		= (winfun (fromJust err) ps,False)

	# linker = linker +++ " -I " +++ quoted_string linkoptspath +++ " -O " +++ quoted_string linkerrspath
	
704
	# (didit,exit_code,ost) = call_process_with_directory linker linkerdir 99
Diederik van Arkel's avatar
Diederik van Arkel committed
705 706
	# diditall = if (ost == 99) didit didit
	| not diditall
707
		=	(winfun ["Error: Unable to run linker: "+++linker] ps, False)
Diederik van Arkel's avatar
Diederik van Arkel committed
708 709 710 711 712 713 714 715 716 717 718
	# link_ok = (exit_code==0) && (ost == 99)
	# ((err,link_errors),ps) = accFiles (ReadLinkErrors linkerrspath) ps
	| isJust err
		= (winfun (fromJust err) ps,False)
	# (errtext,errlines) = (link_errors, length link_errors)
	| errlines<>0
		= (winfun errtext ps,link_ok)
	=  (ps,link_ok)

mangleLinker linkstr` startupdir
	# (linkstr`,opts)		= splitOptions linkstr`
719
	# (shortOK,linkstr)		= GetShortPathName (startupdir +++ DirSeparatorString +++ linkstr` +++ "\0")
Diederik van Arkel's avatar
Diederik van Arkel committed
720
	| not shortOK
721
		# line				= "Error: Unable to get short path name '" +++ (startupdir +++ DirSeparatorString +++ linkstr`) +++ "'."
Diederik van Arkel's avatar
Diederik van Arkel committed
722 723 724 725
		= (False,line,"")
	# linkcom = linkstr % (0, size linkstr - 2) +++ opts
	# linkdir = RemoveFilename (linkstr % (0, size linkstr - 2))
	= (True,linkcom,linkdir)
Diederik van Arkel's avatar
Diederik van Arkel committed
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768

splitOptions str
	| first_q >= len_str	= (str,"")
	= (first_str,last_str)
where
	first_str =  str%(0,dec first_q)
	last_str = str % (inc first_q, len_str)
	len_str = size str
	first_q			= FindQuoteChar str len_str 0
	FindQuoteChar str len pos	= FindChar ':' str len pos;
	FindChar	:: !Char !.String !.Int !Int -> Int;
	FindChar c line linelen pos
		| pos >= linelen		=  pos;
		| c ==  line.[pos]		=  pos;
								=  FindChar c line linelen (inc pos);
/*
splitOptions str
	| first_q >= len_str	= (str,"")
	| last_q >= len_str		= (first_str,"")
	= (first_str,last_str)
where
	first_str =  str%(0,dec first_q)
	last_str = str % (inc first_q, dec last_q)

	len_str = size str
	
	first_q			= FindQuoteChar str len_str 0
	last_q			= FindQuoteChar str len_str (inc first_q)
		
	//	FindQuoteChar	:: !String !Int !Int -> Int;
	FindQuoteChar str len pos	= FindChar '\"' str len pos;

	FindChar	:: !Char !.String !.Int !Int -> Int;
	FindChar c line linelen pos
		| pos >= linelen		=  pos;
		| c ==  line.[pos]		=  pos;
								=  FindChar c line linelen (inc pos);
*/

//--- EXECUTE

Execute`	::	!String !*env -> (!Bool,!Int,!*env)
Execute` command ps
769
	#	(didit, ec, os4)	= call_process command 99
Diederik van Arkel's avatar
Diederik van Arkel committed
770 771 772 773 774 775 776
	    diditall			= if (os4 == 99) didit didit
	| diditall
		= (True,ec,ps)
		= (False,ec,ps)

//--- OTHER STUFF

777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805
call_process :: !{#Char} !*OSToolbox -> (!Bool, !Int, !*OSToolbox)
call_process command os
	| size command>0
		# (ok,process_information,os) = create_process_with_current_directory_pointer (command+++."\0") 0 True 0 os
		| not ok
			= (False, -1, os)
			# process_handle = process_information.[PROCESS_INFORMATION_hProcess_int_offset]
			  thread_handle = process_information.[PROCESS_INFORMATION_hThread_int_offset]
			  (_,os) = WaitForSingleObject process_handle INFINITE os
			  (_,exit_code,os) = GetExitCodeProcess process_handle os
			  (_,os) = CloseHandle thread_handle os
			  (_,os) = CloseHandle process_handle os
			= (True, exit_code, os)
		= (False, -1, os)

call_process_with_directory :: !{#Char} !{#Char} !*OSToolbox -> (!Bool, !Int, !*OSToolbox)
call_process_with_directory command directory os
	| size command>0
		# (ok,process_information,os) = create_process (command+++."\0") (directory+++"\0") False 0 os
		| not ok
			= (False, -1, os)
			# process_handle = process_information.[PROCESS_INFORMATION_hProcess_int_offset]
			  thread_handle = process_information.[PROCESS_INFORMATION_hThread_int_offset]
			  (_,os) = WaitForSingleObject process_handle INFINITE os
			  (_,exit_code,os) = GetExitCodeProcess process_handle os
			  (_,os) = CloseHandle thread_handle os
			  (_,os) = CloseHandle process_handle os
			= (True, exit_code, os)
		= (False, -1, os)
806

807 808
call_process_with_directory_and_redirected_std_error :: !{#Char} !{#Char} !{#Char} !*OSToolbox -> (!Bool, !Int, !*OSToolbox)
call_process_with_directory_and_redirected_std_error command directory errors_file_name os
809 810
	| size command>0
		# (std_error_handle,os) = create_inheritable_file (errors_file_name+++"\0") os
811
		  (ok,process_information,os) = create_process (command+++."\0") (directory+++"\0") True std_error_handle os
812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828
		| not ok
			# (_,os) = CloseHandle std_error_handle os
			= (False, -1, os)
			# process_handle = process_information.[PROCESS_INFORMATION_hProcess_int_offset]
			  thread_handle = process_information.[PROCESS_INFORMATION_hThread_int_offset]
			  (_,os) = WaitForSingleObject process_handle INFINITE os
			  (_,exit_code,os) = GetExitCodeProcess process_handle os
			  (_,os) = CloseHandle std_error_handle os
			  (_,os) = CloseHandle thread_handle os
			  (_,os) = CloseHandle process_handle os
			= (True, exit_code, os)
		= (False, -1, os)

start_process_with_redirected_std_error :: !{#Char} !{#Char} !{#Char} !*OSToolbox -> (!Bool, !HANDLE, !HANDLE, !HANDLE, !*OSToolbox)
start_process_with_redirected_std_error command directory errors_file_name os
	| size command>0
		# (std_error_handle,os) = create_inheritable_file (errors_file_name+++"\0") os
829
		  (ok,process_information,os) = create_process (command+++."\0") (directory+++"\0") True std_error_handle os
830 831 832 833 834 835 836 837
		| not ok
			# (_,os) = CloseHandle std_error_handle os
			= (False, 0, 0, 0, os)
			# process_handle = process_information.[PROCESS_INFORMATION_hProcess_int_offset]
			  thread_handle = process_information.[PROCESS_INFORMATION_hThread_int_offset]
			= (True,process_handle,thread_handle,std_error_handle,os)
		= (False, 0, 0, 0, os)

838
finish_process_with_redirected_std_error :: !HANDLE !HANDLE !HANDLE !*OSToolbox -> *OSToolbox
839
finish_process_with_redirected_std_error process_handle thread_handle std_error_handle os
840
	# (_,os) = CloseHandle std_error_handle os
841 842
	  (_,os) = CloseHandle thread_handle os
	  (_,os) = CloseHandle process_handle os
843
	= os
844

Diederik van Arkel's avatar
Diederik van Arkel committed
845 846 847 848 849 850 851 852 853 854 855 856 857 858 859
// PERSISTENT STUFF

int_to_hex v
	= {hex_char i \\ i<-[0..7]};
where
		hex_char i
			# h=(v>>((7-i)<<2)) bitand 15;
			= toChar (if (h<10) (toInt '0'+h) ((toInt 'A'-10)+h));



:: CompilingInfo = NotCompiling | CompilingInfo !CompilerProcess;

:: CompilerProcess = NoCompiler | CompilerProcess !Int !Int !Int; // thread_id thread_handle process_handle

Diederik van Arkel's avatar
Diederik van Arkel committed
860
InitCompilingInfo :: *CompilingInfo
Diederik van Arkel's avatar
Diederik van Arkel committed
861 862 863
//InitCompilingInfo = NotCompiling
InitCompilingInfo = CompilingInfo NoCompiler

Diederik van Arkel's avatar
Diederik van Arkel committed
864 865 866
compile_with_cache :: String String String String *(*CompilingInfo,*env) -> (!Bool,!Int,!*(*CompilingInfo,*env))
compile_with_cache path directory startup_arguments arguments prog=:(CompilingInfo NoCompiler, ps)
//	# startup_arguments = ""
Diederik van Arkel's avatar
Diederik van Arkel committed
867
	# thread_id=get_current_thread_id;
Diederik van Arkel's avatar
Diederik van Arkel committed
868
	# begin_arguments=startup_arguments+++" -ide "+++int_to_hex thread_id;
869 870
	# (r,compiler_thread_id,compiler_thread_handle,compiler_process_handle)
		= start_compiler_process (IF_BATCHBUILD_OR_IDE 0 dispatch_null_message_hook) (path+++"\0") (directory+++"\0") ("\""+++path+++"\" "+++begin_arguments+++"\0");
Diederik van Arkel's avatar
Diederik van Arkel committed
871
	| r==0
872
		= (False,0,prog)
Diederik van Arkel's avatar
Diederik van Arkel committed
873 874 875 876
	# (ok,s) = compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle;
	| ok
		# ci = CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle)
		= (ok,s,(ci,ps));
877
		= (ok,s,prog);
Diederik van Arkel's avatar
Diederik van Arkel committed
878
compile_with_cache path directory startup_arguments arguments prog=:(CompilingInfo (CompilerProcess compiler_thread_id compiler_thread_handle compiler_process_handle),ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
879 880 881
	# (ok,s) = compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle
	| ok
		= (ok,s,prog)
882
	= (ok,s,(CompilingInfo NoCompiler,ps))
Diederik van Arkel's avatar
Diederik van Arkel committed
883
compile_with_cache path directory startup_arguments arguments prog=:(NotCompiling,ps)
Diederik van Arkel's avatar
Diederik van Arkel committed
884
    # command = quoted_string path +++ " " +++ arguments
885
	# (ok,exitcode, os4) = call_process_with_directory command directory 99
Diederik van Arkel's avatar
Diederik van Arkel committed
886 887 888 889 890 891 892
	= (ok,exitcode,prog)

compile_with_cache2 :: {#.Char} {#.Char} {#.Char} Int Int Int -> (!Bool,!Int)
compile_with_cache2 path directory arguments compiler_thread_id compiler_thread_handle compiler_process_handle
	# wm_number=get_message_number
	# r=send_string_to_thread compiler_thread_id compiler_process_handle wm_number ("cocl "+++arguments+++"\0")
	| r==0
893
		= (False,0)
Diederik van Arkel's avatar
Diederik van Arkel committed
894 895
	# (r,a,s) =get_integers_from_thread_message wm_number compiler_thread_handle
	| r==0
896
		= (False,s)
Diederik van Arkel's avatar
Diederik van Arkel committed
897 898
	= (True,s)

Camil Staps's avatar
Camil Staps committed
899 900 901
RunExternalCommand :: !String ![String] !String !*GeneralSt -> *(!Int, ![String], !*GeneralSt)
RunExternalCommand cmd args startupdir ps
	# command = foldl (\cmd arg -> cmd +++ " " +++ arg) cmd [quoted_string arg \\ arg <- args]
902 903
	| size command >= 32768 = (-1,["Error: command line is too long (consider moving the project to a location closer to the filesystem root): " +++ command % (0,200) +++ "..."],ps)
	# dir = RemoveFilename cmd
Camil Staps's avatar
Camil Staps committed
904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935
	  errorsfilename = tooltempdir +++ DirSeparatorString +++ "errors"
	  (didit,exit_code,_) = call_process_with_directory_and_redirected_std_error command dir errorsfilename 99
	| not didit = abort ("Could not run external command '" +++ command +++ "'\n")
	# (out,ps) = accFiles (readFileLines errorsfilename) ps
	= (exit_code,out,ps)
where
	readFileLines :: !String !*Files -> *(![String], !*Files)
	readFileLines path env
	# (ok,f,env) = fopen path FReadText env
	| not ok = ([], env)
	# (out,f) = read [] f
	# (_,env) = fclose f env
	= (out,env)
	where
		read :: ![String] !*File -> *(![String], !*File)
		read acc f
		# (e,f) = fend f
		| e = (reverse acc,f)
		# (line,f) = freadline f
		#! line = strip_newlines line
		= read [line:acc] f

	strip_newlines :: !{#Char} -> {#Char}
	strip_newlines s
		| size s==0
			= s
			# last = dec (size s)
			  char = s.[last]
			| char == '\n' || char == '\r'
				= strip_newlines (s % (0,dec last))
			= s

936
StartCodeGenerator	::	!String !(WindowFun *GeneralSt) !CodeGenerateAsmOrCode !Pathname !Int !Bool !CodeGenOptions !Processor !ApplicationOptions !Pathname !CompilerProcessIds !*GeneralSt -> (!Bool,!Pathname,!CompilerProcessIds,!*GeneralSt)
937
StartCodeGenerator _ _ _ _ _ _ _ _ _ _ _ _ = undef
Diederik van Arkel's avatar
Diederik van Arkel committed
938 939 940

SendRepeatResult :: !Int !.a -> (!Int,!.a)
SendRepeatResult _ _ = undef
941 942

DelayEventLoop :: !.ps -> .ps
943
DelayEventLoop ps
944 945 946
	| IF_BATCHBUILD_OR_IDE
		True
		(wait_message 0==0)
947 948 949 950 951
		= ps

wait_message :: !Int -> Int;
wait_message r = code {
	ccall WaitMessage@0 "P:V:I"
952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972
}

GENERIC_WRITE:==0x40000000;
CREATE_ALWAYS:==2;
FILE_ATTRIBUTE_NORMAL:==0x00000080;  

SECURITY_ATTRIBUTES_nLength_int_offset:==0;
SECURITY_ATTRIBUTES_bInheritHandle_int_offset:==2;

SECURITY_ATTRIBUTES_size_int:==3;
SECURITY_ATTRIBUTES_size_bytes_32:==12;
SECURITY_ATTRIBUTES_size_bytes_64:==24;
SECURITY_ATTRIBUTES_size_bytes :== IF_INT_64_OR_32 SECURITY_ATTRIBUTES_size_bytes_64 SECURITY_ATTRIBUTES_size_bytes_32;

:: HANDLE:==Int;

create_inheritable_file :: !{#Char} !*OSToolbox -> (!HANDLE,!*OSToolbox);
create_inheritable_file file_name os
	# security_attributes = {createArray SECURITY_ATTRIBUTES_size_int 0 &
	  							[SECURITY_ATTRIBUTES_nLength_int_offset] = SECURITY_ATTRIBUTES_size_bytes,
	  							[SECURITY_ATTRIBUTES_bInheritHandle_int_offset] = 1};
973
	= IF_INT_64_OR_32
974 975
		(CreateFile file_name GENERIC_WRITE 0 security_attributes CREATE_ALWAYS FILE_ATTRIBUTE_NORMAL 0 os)
		(CreateFile_32 file_name GENERIC_WRITE 0 security_attributes CREATE_ALWAYS FILE_ATTRIBUTE_NORMAL 0 os);
976

977 978 979 980
create_process :: !*{#Char} !{#Char} !Bool !HANDLE !*OSToolbox -> (!Bool,!{#Int},!*OSToolbox)
create_process command_line current_directory startf_usestdhandles std_error_handle os
	# flags = if startf_usestdhandles (IF_INT_64_OR_32 (STARTF_USESTDHANDLES<<32) STARTF_USESTDHANDLES) 0;
	  startup_info = {createArray STARTUPINFO_size_int 0 &
981
	  					[STARTUPINFO_cb_int_offset] = STARTUPINFO_size_bytes,
982
						[IF_INT_64_OR_32 STARTUPINFO_dwFlags_int_h_offset_64 STARTUPINFO_dwFlags_int_offset_32] = flags,
983 984
						[STARTUPINFO_hStdError_int_offset] = std_error_handle};
	  process_information = createArray PROCESS_INFORMATION_size_int 0
985 986 987
	  (ok,os) = IF_INT_64_OR_32
	  				(CreateProcess 0 command_line 0 0 True DETACHED_PROCESS 0 current_directory startup_info process_information os)
	  				(CreateProcess_32 0 command_line 0 0 True DETACHED_PROCESS 0 current_directory startup_info process_information os)
988 989
	= (ok,process_information,os)

990 991 992 993 994 995 996 997 998 999 1000 1001 1002
create_process_with_current_directory_pointer :: !*{#Char} !Int !Bool !HANDLE !*OSToolbox -> (!Bool,!{#Int},!*OSToolbox)
create_process_with_current_directory_pointer command_line current_directory_p startf_usestdhandles std_error_handle os
	# flags = if startf_usestdhandles (IF_INT_64_OR_32 (STARTF_USESTDHANDLES<<32) STARTF_USESTDHANDLES) 0;
	  startup_info = {createArray STARTUPINFO_size_int 0 &
	  					[STARTUPINFO_cb_int_offset] = STARTUPINFO_size_bytes,
						[IF_INT_64_OR_32 STARTUPINFO_dwFlags_int_h_offset_64 STARTUPINFO_dwFlags_int_offset_32] = flags,
						[STARTUPINFO_hStdError_int_offset] = std_error_handle};
	  process_information = createArray PROCESS_INFORMATION_size_int 0
	  (ok,os) = IF_INT_64_OR_32
	  				(CreateProcess_with_current_directory_pointer 0 command_line 0 0 True DETACHED_PROCESS 0 current_directory_p startup_info process_information os)
	  				(CreateProcess_with_current_directory_pointer_32 0 command_line 0 0 True DETACHED_PROCESS 0 current_directory_p startup_info process_information os)
	= (ok,process_information,os)

1003 1004 1005 1006 1007 1008
CreateFile_32 :: !{#Char} !Int !Int !{#Int} !Int !Int !HANDLE !*OSToolbox -> (!HANDLE,!*OSToolbox);
CreateFile_32 fileName desiredAccess shareMode lpSecurityAttributes creationDisposition flagsAndAttributes templateFile os
	= code {
		ccall CreateFileA@28 "PsIIAIII:I:I"
	}

1009 1010 1011 1012 1013 1014
CreateFile :: !{#Char} !Int !Int !{#Int} !Int !Int !HANDLE !*OSToolbox -> (!HANDLE,!*OSToolbox);
CreateFile fileName desiredAccess shareMode lpSecurityAttributes creationDisposition flagsAndAttributes templateFile os
	= code {
		ccall CreateFileA@28 "PsIIAIIp:I:I"
	}

1015
:: LPCSTR:==Int;
1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052
:: LPSECURITY_ATTRIBUTES:==Int;
:: LPVOID:==Int;
:: LPSTARTUPINFO:==Int;
:: LPPROCESS_INFORMATION:==Int;

STARTF_USESTDHANDLES:==0x00000100;

STARTUPINFO_size_int_32:==17;
STARTUPINFO_size_bytes_32:==68;

STARTUPINFO_size_int_64:==13;
STARTUPINFO_size_bytes_64:==104;

STARTUPINFO_size_int :== IF_INT_64_OR_32 STARTUPINFO_size_int_64 STARTUPINFO_size_int_32;
STARTUPINFO_size_bytes :== IF_INT_64_OR_32 STARTUPINFO_size_bytes_64 STARTUPINFO_size_bytes_32;

STARTUPINFO_cb_int_offset:==0;

STARTUPINFO_dwFlags_int_offset_32:==11;
STARTUPINFO_hStdError_int_offset_32:==16;

STARTUPINFO_dwFlags_int_h_offset_64:==7;
STARTUPINFO_hStdError_int_offset_64:==12;

STARTUPINFO_hStdError_int_offset :== IF_INT_64_OR_32 STARTUPINFO_hStdError_int_offset_64 STARTUPINFO_hStdError_int_offset_32;

PROCESS_INFORMATION_size_int_32:==4;

PROCESS_INFORMATION_size_int_64:==3;

PROCESS_INFORMATION_size_int :== IF_INT_64_OR_32 PROCESS_INFORMATION_size_int_64 PROCESS_INFORMATION_size_int_32;

PROCESS_INFORMATION_hProcess_int_offset:==0;
PROCESS_INFORMATION_hThread_int_offset:==1;

DETACHED_PROCESS:==8;

1053
CreateProcess :: !LPCSTR !*{#Char} !LPSECURITY_ATTRIBUTES !LPSECURITY_ATTRIBUTES !Bool !Int !LPVOID
1054
					!{#Char} !{#Int} !{#Int} !*OSToolbox -> (!Bool,!*OSToolbox)
1055
CreateProcess lpApplicationName commandLine lpProcessAttributes lpThreadAttributes inheritHandles creationFlags lpEnvironment
1056 1057
					currentDirectory lpStartupInfo lpProcessInformation os
	= code {
1058
		ccall CreateProcessA@40 "PpsppIIpsAA:I:I"
1059 1060
	}

1061
CreateProcess_32 :: !LPCSTR !*{#Char} !LPSECURITY_ATTRIBUTES !LPSECURITY_ATTRIBUTES !Bool !Int !LPVOID
1062
					!{#Char} !{#Int} !{#Int} !*OSToolbox -> (!Bool,!*OSToolbox)
1063
CreateProcess_32 lpApplicationName commandLine lpProcessAttributes lpThreadAttributes inheritHandles creationFlags lpEnvironment
1064 1065
					currentDirectory lpStartupInfo lpProcessInformation os
	= code {
1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076