Unix version

main/Unix/CoclSystemDependent.dcl

+// this is for Windows
+definition module CoclSystemDependent
+
+//1.3
+from StdString import String
+from StdFile import Files
+//3.1
+/*2.0
+from StdFile import ::Files
+0.2*/
+
+// RWS split
+// from deltaIOSystem import DeviceSystem
+// from deltaEventIO import InitialIO, IOState
+
+PathSeparator
+	:==	':'
+DirectorySeparator
+	:== '/'
+
+SystemDependentDevices :: [a]
+SystemDependentInitialIO :: [a]
+
+ensureCleanSystemFilesExists :: !String !*Files -> (!Bool, !*Files)
+
+set_compiler_id :: Int -> Int

main/Unix/CoclSystemDependent.icl

+// this is for Unix
+implementation module CoclSystemDependent
+
+import StdEnv
+
+// import for filesystem
+import code from "cDirectory.o" // Unix
+import code from "ipc.o"
+from filesystem import ensureDirectoryExists
+
+PathSeparator
+	:==	':'
+DirectorySeparator
+	:== '/'
+
+SystemDependentDevices :: [a]
+SystemDependentDevices
+		=	[]
+
+SystemDependentInitialIO :: [a]
+SystemDependentInitialIO
+		=	[]
+
+ensureCleanSystemFilesExists :: !String !*Files -> (!Bool, !*Files)
+// returned bool: now there is such a subfolder
+ensureCleanSystemFilesExists path env
+	= ensureDirectoryExists path env
+
+set_compiler_id :: Int -> Int
+set_compiler_id compiler_id = compiler_id

main/Unix/ipc.c

+/*
+	Unix clm/cocl interface
+
+	Ronny Wichers Schreur
+
+*/
+# include <stdio.h>
+# include <stdlib.h>
+# include <stdarg.h>
+# include <strings.h>
+
+/*
+	Clean string
+	============
+*/
+typedef struct clean_string {int length; char chars [1]; } *CleanString;
+
+# define Clean(ignore)
+# include "ipc.h"
+
+static void
+log (char *format, ...)
+{
+#ifdef DEBUG
+	va_list ap;
+
+	va_start (ap, format);
+	(void) fputs("                        cocl: ", stderr);
+	(void) vfprintf(stderr, format, ap);
+	va_end(ap);
+#else /* ifndef DEBUG */
+#endif
+}
+
+static char *
+ConvertCleanString (CleanString string)
+{
+	int		length;
+	char	*copy;
+
+	length	= string->length;
+	copy	= malloc (length+1);
+	strncpy (copy, string->chars, length);
+	copy [length]	= '\0';
+
+	return (copy);
+} /* ConvertCleanString */
+
+static FILE *commands, *results;
+# define COMMAND_BUFFER_SIZE 1024
+static char command_buffer[COMMAND_BUFFER_SIZE];
+
+static void
+crash (void)
+{
+	int	*p;
+
+	p	= NULL;
+	log ("crashing\n");
+	*p	= 0;
+} /* crash */
+
+static void
+hang (void)
+{
+	log ("hanging\n");
+	for (;;)
+		;
+} /* hang */
+
+int open_pipes (CleanString commands_clean, CleanString results_clean)
+{
+	char *commands_name, *results_name;
+
+	commands_name	= ConvertCleanString (commands_clean);
+	results_name	= ConvertCleanString (results_clean);
+
+    if ((commands = fopen(commands_name, "r")) == NULL)
+    {
+		fprintf(stderr,"commands = %s\n",commands_name);
+		perror("fopen commands");
+		return -1;
+    }
+    if ((results = fopen(results_name, "w")) == NULL)
+    {
+		fprintf(stderr,"results = %s\n",results_name);
+		perror("fopen results");
+		return -1;
+    }
+	return 0;
+}
+
+int get_command_length (void)
+{
+	log ("reading command\n");
+	if (fgets (command_buffer, COMMAND_BUFFER_SIZE, commands) == NULL)
+		return -1;
+	else	
+	{
+		log ("command = %s", command_buffer);
+		return (strlen (command_buffer));
+	}
+}
+
+int get_command (CleanString cleanString)
+{
+	fprintf (stderr, "%s\n", command_buffer);
+	strncpy (cleanString->chars, command_buffer, cleanString->length);
+	cleanString->chars [cleanString->length]	= '\0';
+
+	return (0);
+}
+
+int send_result (int result)
+{
+	int	r;
+
+	if (fprintf (results, "%d\n", result) > 0)
+		r=0;
+	else
+		r=-1;
+	fflush (results);
+
+	return r;
+}

main/Unix/ipc.dcl

+definition module ipc;
+
+from StdString import String;
+
+open_pipes :: !String !String -> Int;
+// int open_pipes (CleanString commands_name,CleanString results_name);
+get_command_length :: Int;
+// int get_command_length ();
+get_command :: !String -> Int;
+// int get_command (CleanString cleanString);
+send_result :: !Int -> Int;
+// int send_result (int result);

main/Unix/ipc.h

+int open_pipes (CleanString commands_name, CleanString results_name);
+Clean (open_pipes :: String String -> Int)
+int get_command_length (void);
+Clean (get_command_length :: Int)
+int get_command (CleanString cleanString);
+Clean (get_command :: String -> Int)
+int send_result (int result);
+Clean (send_result :: Int -> Int)

main/Unix/ipc.icl

+implementation module ipc;
+
+from StdString import String;
+
+
+open_pipes :: !String !String -> Int;
+open_pipes a0 a1 = code {
+	ccall open_pipes "SS:I"
+}
+// int open_pipes (CleanString commands_name,CleanString results_name);
+
+get_command_length :: Int;
+get_command_length  = code {
+	ccall get_command_length ":I"
+}
+// int get_command_length ();
+
+get_command :: !String -> Int;
+get_command a0 = code {
+	ccall get_command "S:I"
+}
+// int get_command (CleanString cleanString);
+
+send_result :: !Int -> Int;
+send_result a0 = code {
+	ccall send_result "I:I"
+}
+// int send_result (int result);

main/Unix/set_return_code.dcl

+definition module set_return_code;
+
+//1.3
+from StdString import String;
+//3.1
+
+:: *UniqueWorld :== World;
+set_return_code :: !Int !UniqueWorld -> UniqueWorld;
+// void set_return_code (int return_code);

main/Unix/set_return_code.icl

+implementation module set_return_code;
+
+import code from "set_return_code.obj";
+
+import StdString;
+import StdDebug;
+
+:: *UniqueWorld :== World;
+
+set_return_code :: !Int !UniqueWorld -> UniqueWorld;
+set_return_code a0 a1 = code
+{
+	ccall set_return_code "I:V:A"
+	fill_a 0 1
+	pop_a 1
+}
+
+// void set_return_code (int return_code);

main/Unix/set_return_code_c.c

+extern int return_code;
+
+void set_return_code (int code)
+{
+	return_code	=	code;
+}

main/cocl.icl

@@ -8,10 +8,14 @@ import StdEnv
 import coclmain
 
 import frontend
+import StdDebug
 
 // Start :: *World -> *World
 Start world
-	=	(testArgs, coclMain testArgs world)
+	# world = trace_n "hello from cocl!\n" world
+	# world
+		=	coclMain testArgs world
+	= trace_n "bye from cocl!\n" world
 	where
 		testArgs
 			=	[

main/coclmain.icl

@@ -4,6 +4,7 @@
 implementation module coclmain
 
 import StdEnv
+import StdDebug
 import ArgEnv
 import set_return_code
 
@@ -12,12 +13,14 @@ import compile
 coclMain :: ![{#Char}] !*World -> *World
 // currentVersion latestDefVersion latestImpVersion testArgs world
 coclMain  testArgs world
+	# world
+		=	set_return_code 0 world
 	# (commandArgs, world)
 		=	getCommandArgs (tl [arg \\ arg <-: getCommandLine]) testArgs world 
 	# (symbol_table,world)
 		= init_identifiers newHeap world
 	# (success, world)
-		=	accFiles (compiler commandArgs symbol_table) world
+		=	accFiles (compiler symbol_table) world
 	=	set_return_code (if success 0(-1)) world
 	where
 		getCommandArgs :: [{#Char}] [{#Char}] *World -> ([{#Char}], *World)
@@ -75,19 +78,40 @@ coclMain  testArgs world
 
 CoclArgsFile :== "coclargs.txt"
 
+/*
 import thread_message;
 
 import code from "thread_message.obj";
+*/
+
+// compiler driver
 
-compiler :: ![{#Char}] *SymbolTable *Files -> *(!Bool,!*Files);
-compiler commandArgs symbol_table files
+/* Windows
+compiler symbol_table files
 	# dcl_cache = empty_cache symbol_table
 	| length commandArgs==2 && commandArgs!!0=="-ide"
 		# wm_number=get_message_number;
 		# thread_id=hex_to_int (commandArgs!!1);
-		= (True,compile_files dcl_cache thread_id wm_number files)
-		# (r,cache,files)=compile commandArgs dcl_cache files
+		= (True,compile_files compile dcl_cache thread_id wm_number files)
+		# (r,dcl_cache,files)=compile commandArgs dcl_cache files
+		= (r,files)
+	where
+		commandArgs
+			=	tl [arg \\ arg <-: getCommandLine]
+*/
+// Unix
+compiler symbol_table files
+	# dcl_cache = empty_cache symbol_table
+	| length commandArgs==3 && commandArgs!!0=="--pipe"
+		# commands_name= (commandArgs!!1);
+		# results_name= (commandArgs!!2);
+		= (True,compile_loop compile dcl_cache commands_name results_name files)
+		# (r,dcl_cache,files)=compile commandArgs dcl_cache files
 		= (r,files)
+	where
+		commandArgs
+			=	tl [arg \\ arg <-: getCommandLine]
+// ... Unix
 
 hex_to_int :: {#Char} -> Int
 hex_to_int s
@@ -150,24 +174,35 @@ string_to_args string
 				= i;
 				= skip_to_double_quote (i+1);
 
-compile_files cache thread_id wm_number files
-	# (r,a,s) =get_integers_from_message wm_number;
-	| r==0
+// Unix
+import ipc
+import code from "ipc.o"
+
+compile_loop compile cache commands results files
+	# r=open_pipes commands results;
+	| r<>0
+		= abort ("compile_loop\n");
+	=	compile_files compile cache files
+	
+
+compile_files compile cache files
+	# n = get_command_length;
+	| n==(-1)
 		= abort "compile_files 1";
-	# string=createArray a '\0';
-	# r=get_string_from_file_map_and_delete_map s string;
-	| r==0
+	# string=createArray n '\0';
+	# r=get_command string;
+	| r<>0
 		= abort ("compile_files 2 ");
 	# args=string_to_args (string % (0,size string-2))
 	= case args of
 		["cocl":cocl_args]
 			# (ok,cache,files)=compile cocl_args cache files
 			# result=if ok 0(-1);
-			# r=send_integers_to_thread thread_id wm_number 0 result;
-			| r==0
+			# r=send_result result
+			| r<>0
 				-> abort "compile_files 3";
-				-> compile_files cache thread_id wm_number files
-		["exit"]
-			-> files;
+				-> compile_files compile cache files
+		["quit"]
+			-> trace_n "quiting" files;
 		_
 				-> abort "compile_files 4"

main/compile.icl

@@ -16,6 +16,7 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy
 ::	CoclOptions =
 	{	moduleName:: {#Char}
 	,	pathName ::{#Char}
+	,	outputPathName ::{#Char}
 	,	errorPath:: {#Char}
 	,	errorMode::	Int
 	,	outPath:: {#Char}
@@ -28,12 +29,16 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy
 	,	compile_with_generics   :: !Bool
 	}
 
+StdErrPathName :== "_stderr_"
+StdOutPathName :== "_stderr_"
+
 InitialCoclOptions =
 	{	moduleName=	""
 	,	pathName=	""
-	,	errorPath=	"errors"
+	,	outputPathName=	""
+	,	errorPath=	StdErrPathName
 	,	errorMode=	FWriteText
-	,	outPath=	"out"
+	,	outPath=	StdErrPathName
 	,	outMode=	FWriteText
 	,	searchPaths=	{sp_locations = [], sp_paths = []}
 	,	listTypes = {lto_showAttributes = True, lto_listTypesKind = ListTypesNone}
@@ -68,6 +73,8 @@ compile args cache files
 parseCommandLine :: [{#Char}] CoclOptions -> ([{#Char}],[{#Char}],CoclOptions)
 parseCommandLine [] options
 	=	([],[],options)
+parseCommandLine [arg1=:"-o", outputPathName : args] options=:{searchPaths}
+        =       parseCommandLine args {options & outputPathName = outputPathName}
 parseCommandLine [arg1=:"-P", searchPathsString : args] options=:{searchPaths}
 // RWS, voor Maarten +++	=	parseCommandLine args {options & searchPaths = {searchPaths & sp_paths = splitPaths searchPathsString}}
 	# (args,modules,options) =	parseCommandLine args {options & searchPaths.sp_paths = splitPaths searchPathsString}
@@ -158,14 +165,25 @@ compile_modules [module_:modules] n_compiles cocl_options args_without_modules c
 compile_modules [] n_compiles cocl_options args_without_modules cache files
 	= (True,cache,files);
 
+openPath :: {#Char} Int *Files -> (Bool, *File, *Files)
+openPath path mode files
+	| path == StdErrPathName
+		=	(True, stderr, files)
+	| path == StdOutPathName
+		# (io, files)
+			=	stdio files
+		=	(True, io, files)
+	// otherwise
+		=	fopen path mode files
+
 compileModule :: CoclOptions [{#Char}] *DclCache *Files -> (!Bool,!*DclCache,!*Files)
 compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files
 	# (opened, error, files)
-		=	fopen options.errorPath options.errorMode files
+		=	openPath options.errorPath options.errorMode files
 	| not opened
 		=	abort ("couldn't open error file \"" +++ options.errorPath +++ "\"\n")
 	# (opened, out, files)
-		=	fopen options.outPath options.outMode files
+		=	openPath options.outPath options.outMode files
 	| not opened
 		=	abort ("couldn't open out file \"" +++ options.outPath +++ "\"\n")
 	# (tcl_file, files)
@@ -210,8 +228,9 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo
 				  							 <<< options.moduleName <<< '\n')
 				  			error
 				# (success, var_heap, attrHeap, error, files)
-					= backEndInterface outputPath (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files
+				 	 = backEndInterface outputPath (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files
 				-> (success,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files)
+				// -> (True,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files)
 				with
 					appendRedirection arg
 						= case arg of
@@ -224,6 +243,12 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo
 			No
 				-> (False,{},0,var_heap,attrHeap,error, files)
 		with
+/*
+			outputPath
+				=	if (options.outputPathName == "")
+						(directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ baseName options.pathName)
+						options.outputPathName
+*/
 			outputPath
 	//				=	/* directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ */ baseName options.pathName
 				=	baseName options.pathName
@@ -237,4 +262,4 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo
 		# cache={dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=unique_copy_of_predef_symbols,hash_table=hash_table,heaps=heaps}
 		= (success,cache,files)
 		# cache={dcl_modules=cached_dcl_mods,functions_and_macros=cached_functions_and_macros,predef_symbols=unique_copy_of_predef_symbols,hash_table=hash_table,heaps=heaps}
-		= (success,cache,files)
\ No newline at end of file
+		= (success,cache,files)