This commit was manufactured by cvs2svn to create tag 'init2'.

main/CleanCocl.icl

+module CleanCocl
+
+import StdEnv
+import deltaEventIO, deltaIOState
+import CoclSystemDependent
+
+Don`tCareId
+	:==	0
+
+Start :: !*World -> *World
+Start world
+	# (_, world)
+		=	StartIO [menus : SystemDependentDevices] 0 SystemDependentInitialIO world
+		with
+			menus
+				=	MenuSystem [file]
+			file
+				=	PullDownMenu Don`tCareId "File" Able
+						[MenuItem Don`tCareId "Quit" (Key 'Q') Able Quit]
+	=	world
+
+Quit :: *s (IOState *s) -> (*s, IOState *s)
+Quit s io
+	=	(s, QuitIO io)

main/Mac/CoclSystemDependent.dcl

+// this is for the PowerMac
+definition module CoclSystemDependent
+
+from deltaIOSystem import DeviceSystem
+from deltaEventIO import InitialIO, IOState
+
+PathSeparator
+	:==	','
+DirectorySeparator
+	:==	':'
+
+SystemDependentDevices :: [DeviceSystem .a (IOState .a)]
+SystemDependentInitialIO :: InitialIO *s

main/Mac/CoclSystemDependent.icl

+// this is for the PowerMac
+implementation module CoclSystemDependent
+
+import StdEnv
+import deltaIOSystem, deltaEventIO, deltaIOState
+import AppleEventDevice
+import compile
+import docommand
+import RWSDebug
+
+PathSeparator
+	:==	','
+DirectorySeparator
+	:==	':'
+
+SystemDependentDevices :: [DeviceSystem .a (IOState .a)]
+SystemDependentDevices
+		=	[AppleEventSystem {openHandler = openDummy, quitHandler = Quit,
+								clipboardChangedHandler = clipboardDummy, scriptHandler = scriptHandler}];
+		where
+			openDummy filePath s io
+				=	(s, io) <<- ("open", filePath)
+			clipboardDummy s io
+				=	(s, io) <<- "clipboard"
+
+		/*
+			scriptHandler script s io
+				# (result, env) = DoCommandNullTerminated (script +++ "\0") 17
+				| result >= 0
+					=	(s, io)
+				// otherwise
+					=	(s, io) <<- ("error in docommand", result, script)
+		*/
+			scriptHandler script s io
+				=	(s, appFiles (compile (processArgs script)) io) <<- ("script", processArgs script)
+				where
+					processArgs s
+						=	[replace arg \\ arg <- filter ((<>) "") (splitArgs s)]
+
+					replace s
+						| s == "\xb3" /* \xb3 == >= ligature */
+							=	"-RE"
+						| s == ">"
+							=	"-RO"
+						// otherwise
+							=	s
+					splitArgs s
+						=	split False 0 0 (size s) s
+					split quoted frm to n s
+						| to >= n
+							=	[s % (frm, to)]
+						| s.[to] == '\\' && to < n-1
+							=	split quoted frm (to+2) n s
+						| s.[to] == ' ' && not quoted 
+							=	[s % (frm, to-1) : split False (to+1) (to+1) n s]
+						| s.[to] == '\'' && quoted
+							=	[s % (frm, to-1) : split False (to+1) (to+1) n s]
+						| s.[to] == '\''
+							=	[s % (frm, to-1) : split True (to+1) (to+1) n s]
+						// otherwise
+							=	split quoted frm (to+1) n s
+
+SystemDependentInitialIO :: InitialIO *s
+SystemDependentInitialIO
+		=	[]
+
+Quit :: *s (IOState *s) -> (*s, IOState *s)
+Quit s io
+	=	(s, QuitIO io)

main/Version.dcl

+definition module Version
+
+:: VersionInfo =
+	{	versionCurrent
+			:: Int
+	,	versionOldestDefinition
+			:: Int
+	,	versionOldestImplementation
+			:: Int
+	}
+
+:: VersionsCompatability
+	=	VersionsAreCompatible
+	|	VersionObservedIsTooOld
+	|	VersionObservedIsTooNew
+
+versionCompare :: VersionInfo VersionInfo -> VersionsCompatability
+// expected observed

main/Version.icl

+implementation module Version
+
+import StdInt, StdClass
+
+:: VersionInfo =
+	{	versionCurrent
+			:: Int
+	,	versionOldestDefinition
+			:: Int
+	,	versionOldestImplementation
+			:: Int
+	}
+
+:: VersionsCompatability
+	=	VersionsAreCompatible
+	|	VersionObservedIsTooOld
+	|	VersionObservedIsTooNew
+
+versionCompare :: VersionInfo VersionInfo -> VersionsCompatability
+versionCompare expected observed
+	| expected.versionCurrent < observed.versionCurrent
+		| expected.versionCurrent >= observed.versionOldestDefinition
+			=	VersionsAreCompatible
+		// otherwise
+			=	VersionObservedIsTooNew
+	| expected.versionCurrent == observed.versionCurrent
+		=	VersionsAreCompatible
+	// expected.versionCurrent > observed.versionCurrent
+		| expected.versionOldestImplementation <= observed.versionCurrent
+			=	VersionsAreCompatible
+		// otherwise
+			=	VersionObservedIsTooOld

main/Windows/CoclSystemDependent.dcl

+// this is for Windows
+definition module CoclSystemDependent
+
+// RWS split
+// from deltaIOSystem import DeviceSystem
+// from deltaEventIO import InitialIO, IOState
+
+PathSeparator
+	:==	';'
+DirectorySeparator
+	:== '\\'
+
+SystemDependentDevices :: [a]
+SystemDependentInitialIO :: [a]

main/Windows/CoclSystemDependent.icl

+// this is for Windows
+implementation module CoclSystemDependent
+
+PathSeparator
+	:==	';'
+DirectorySeparator
+	:== '\\'
+
+SystemDependentDevices :: [a]
+SystemDependentDevices
+		=	[]
+
+SystemDependentInitialIO :: [a]
+SystemDependentInitialIO
+		=	[]

main/Windows/set_return_code.dcl

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

main/Windows/set_return_code.icl

+implementation module set_return_code;
+
+import code from "set_return_code.obj";
+
+from StdString import String;
+
+:: *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/cocl.icl

+module cocl
+
+import coclmain
+import StdString
+import StdEnv
+
+Start :: *World -> *World
+Start world
+	=	coclMain testArgs world
+	where
+		testArgs
+			=	[
+					// main module			
+//					"Dialog1"
+					"t"
+//					"typesupport.icl"
+//					"EdProject.icl"
+					// list all types
+				,	"-lat"
+					// generate readable abc code
+				,	"-d"
+					// redirect out
+				,	"-RO", "messages.txt"	
+					// redirect errors
+				,	"-RE", "errors.txt"
+					// paths
+				,	"-P", clean20Dir +++ "StdEnv" +++ ";" +++ clean20Dir +++ "IOInterface"
+					// test specific
+					+++ ";" +++ testDir
+//					+++ ";" +++ clean20Dir +++ "test\\Clean 2 Compiler Test"
+//					+++ ";" +++ ideDir +++ ";" +++ ideDir +++ "Windows\\" +++ ";" +++ ideDir +++ "Util\\"
+				]
+		testDir
+			=	"e:\\Users\\Ronny\\Develop\\Clean Programs\\"
+		clean20Dir
+			=	"e:\\Users\\Ronny\\Develop\\CleanSystem\\2.0\\"
+		ideDir
+			=	clean20Dir +++ "test\\Clean IDE\\"

main/coclmain.dcl

+definition module coclmain
+
+/*
+	The coclmain library
+
+	includes
+		compile
+		backend (needs dynamic library backend.dll)
+		ArgEnv
+		Version
+		set_return_code
+
+	uses
+		StdEnv
+		compiler
+
+	This library is compiled with profiling code. This means that profiling
+	should also be enabled in projects that use the coclmain library.
+
+	Note:	The interface from coclmain to the compiler is not version checked.
+			It's safest to build and use a new coclmain library whenever the
+			type of the compiler's syntax tree changes.
+*/
+
+// coclMain :: ![{#Char}] !*World -> *World
+// testArgs world
+coclMain :== coclMainWithVersionCheck CoclMainVersionCurrent CoclMainVersionLatestDef CoclMainVersionLatestImp
+
+CoclMainVersionCurrent
+	:==	0x02000205
+CoclMainVersionLatestDef
+	:==	0x02000205
+CoclMainVersionLatestImp
+	:==	0x02000205
+
+coclMainWithVersionCheck :: !Int !Int !Int ![{#Char}] !*World -> *World
+// currentVersion latestDefVersion latestImpVersion testArgs world

main/coclmain.icl

+implementation module coclmain
+
+CoclMainVersion :== 0
+
+import StdEnv
+import ArgEnv
+import Version
+import set_return_code
+
+import compile
+
+// coclMain :: ![{#Char}] !*World -> *World
+// testArgs world
+coclMain :== coclMainWithVersionCheck CoclMainVersionCurrent CoclMainVersionLatestDef CoclMainVersionLatestImp
+
+CoclMainVersionCurrent
+	:==	0x02000205
+CoclMainVersionLatestDef
+	:==	0x02000205
+CoclMainVersionLatestImp
+	:==	0x02000205
+
+checkVersion :: VersionsCompatability *File -> (!Bool, !*File)
+checkVersion VersionsAreCompatible errorFile
+	=	(True, errorFile)
+checkVersion VersionObservedIsTooNew errorFile
+	#	errorFile
+			=	fwrites "[Coclmain] the library is too new\n" errorFile
+	=	(False, errorFile)
+checkVersion VersionObservedIsTooOld errorFile
+	#	errorFile
+			=	fwrites "[Coclmain] the library is too old\n" errorFile
+	=	(False, errorFile)
+
+coclMainWithVersionCheck :: !Int !Int !Int ![{#Char}] !*World -> *World
+// currentVersion latestDefVersion latestImpVersion testArgs world
+coclMainWithVersionCheck  currentVersion latestDefVersion latestImpVersion testArgs world
+	# observedVersion =
+		{	versionCurrent
+				=	CoclMainVersionCurrent
+		,	versionOldestDefinition
+				=	CoclMainVersionLatestDef
+		,	versionOldestImplementation
+				=	CoclMainVersionLatestImp
+		}
+	  expectedVersion =
+		{	versionCurrent
+				=	currentVersion
+		,	versionOldestDefinition
+				=	latestDefVersion
+		,	versionOldestImplementation
+				=	latestImpVersion
+		}
+	| not (fst (checkVersion (versionCompare expectedVersion observedVersion) stderr))
+		=	set_return_code (-1) world
+	# (success, world)
+		=	accFiles (compile commandArgs) world
+	=	set_return_code (if success 0(-1)) world
+	where
+		commandArgs
+			=	if (length realArgs == 0) testArgs realArgs
+		realArgs
+			=	tl [arg \\ arg <-: getCommandLine]

main/compile.dcl

+definition module compile
+
+from StdFile import Files
+
+compile :: [{#Char}] *Files -> (!Bool, !*Files)

main/compile.icl

+implementation module compile
+
+import StdEnv
+import frontend
+import backendinterface
+import CoclSystemDependent
+import RWSDebug
+
+::	CoclOptions =
+	{
+		moduleName
+			:: {#Char}
+	,	pathName
+			:: {#Char}
+	,	errorPath
+			:: {#Char}
+	,	errorMode
+			::	Int
+	,	outPath
+			:: {#Char}
+	,	outMode
+			::	Int
+	,	searchPaths
+			:: SearchPaths
+	}
+
+InitialCoclOptions =
+	{	moduleName
+			=	""
+	,	pathName
+			=	""
+	,	errorPath
+			=	"errors"
+	,	errorMode
+			=	FWriteText
+	,	outPath
+			=	"messages"
+	,	outMode
+			=	FWriteText
+	,	searchPaths
+// RWS, voor Maarten +++			=	{sp_locations = [], sp_paths = []}
+				=	[]
+	}
+
+compile :: [{#Char}] *Files -> (!Bool, !*Files)
+compile args files
+	=	compileModule (parseCommandLine args InitialCoclOptions) args files
+
+parseCommandLine :: [{#Char}] CoclOptions -> CoclOptions
+parseCommandLine [] options
+	=	prependModulePath options
+	where
+		// RWS +++ hack, both module name and file path should be passed to frontEndInterface
+		prependModulePath options=:{pathName, searchPaths}
+			=	{	options
+				&	moduleName = baseName pathName
+// RWS, voor Maarten +++				,	searchPaths = {searchPaths & sp_paths = [directoryName pathName : searchPaths.sp_paths]}
+				,	searchPaths = [directoryName pathName : searchPaths]
+				}
+parseCommandLine ["-P", searchPathsString : args] options=:{searchPaths}
+// RWS, voor Maarten +++	=	parseCommandLine args {options & searchPaths = {searchPaths & sp_paths = splitPaths searchPathsString}}
+	=	parseCommandLine args {options & searchPaths = splitPaths searchPathsString}
+parseCommandLine ["-RO", outPath : args] options
+	=	parseCommandLine args {options & outPath = stripQuotes outPath, outMode = FWriteText}
+parseCommandLine ["-RAO", outPath : args] options
+	=	parseCommandLine args {options & outPath = stripQuotes outPath, outMode = FAppendText}
+parseCommandLine ["-RE", errorPath : args] options
+	=	parseCommandLine args {options & errorPath = stripQuotes errorPath, errorMode = FWriteText}
+parseCommandLine ["-RAE", errorPath : args] options
+	=	parseCommandLine args {options & errorPath = stripQuotes errorPath, errorMode = FAppendText}
+parseCommandLine [arg : args] options
+	| arg.[0] == '-'
+		=	parseCommandLine args options
+	// otherwise
+		=	parseCommandLine args {options & pathName = stripExtension ".icl" (stripQuotes arg)}
+
+stripExtension :: {#Char} {#Char} -> {#Char}
+stripExtension extension string
+	| stringSize >= extensionSize && (string % (stringSize-extensionSize, stringSize-1)) == extension
+		=	string % (0, stringSize-extensionSize-1)
+	// otherwise
+		=	string
+	where
+		stringSize
+			=	size string
+		extensionSize
+			=	size extension
+
+stripQuotes :: {#Char} -> {#Char}
+stripQuotes string
+	| stringSize > 1 && string.[0] == '"' && string.[stringSize-1] == '"'
+		=	string % (1, stringSize-2)
+	// otherwise
+		=	string
+	where
+		stringSize
+			=	size string
+
+splitPaths :: {#Char} -> [{#Char}]
+splitPaths paths
+	=	[path +++ {DirectorySeparator} \\ path <- splitBy PathSeparator paths]
+
+splitBy :: Char {#Char} -> [{#Char}]
+splitBy char string
+	=	splitBy` 0 0
+	where
+		splitBy` frm to
+			| to >= stringSize
+				=	[string % (frm, to-1)]
+			| string.[to] == char
+				=	[string % (frm, to-1) : splitBy` (to+1) (to+1)]
+			// otherwise
+				=	splitBy` frm (to+1)
+		stringSize
+			=	size string
+
+baseName :: {#Char} -> {#Char}
+baseName path
+	=	last (splitBy DirectorySeparator path)
+
+directoryName :: {#Char} -> {#Char}
+directoryName path
+	=	foldr (\p ps -> p +++ {DirectorySeparator} +++ ps) "" (init (splitBy DirectorySeparator path))
+
+compileModule :: CoclOptions [{#Char}] *Files -> (!Bool, !*Files)
+compileModule options commandLineArgs files
+	# (opened, error, files)
+		=	fopen 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
+	| not opened
+		=	abort ("couldn't open out file \"" +++ options.outPath +++ "\"\n")
+	# (io, files)
+		=	stdio files
+
+	# (predefSymbols, hashTable) = buildPredefinedSymbols newHashTable
+	  (moduleIdent, hashTable) = putIdentInHashTable options.moduleName IC_Module hashTable
+	# (predefs, _, files, error, io, out, optionalSyntaxTree)
+		=	frontEndInterface moduleIdent options.searchPaths predefSymbols hashTable files error io out
+	# (closed, files)
+		=	fclose io files
+	| not closed
+		=	abort ("couldn't close stdio")
+	# (closed, files)
+		=	fclose out files
+	| not closed
+		=	abort ("couldn't close out file \"" +++ options.outPath +++ "\"\n")
+	# (success, error, files)
+		=	case optionalSyntaxTree of
+				Yes syntaxTree
+					->	backEndInterface outputPath (map appendRedirection commandLineArgs) predefs syntaxTree error files
+					with
+						appendRedirection arg
+							= case arg of
+								"-RE"
+									-> "-RAE"
+								"-RO"
+									-> "-RAO"
+								arg
+									->	arg
+				No
+					-> (False, error, files)
+		with
+			outputPath
+	//				=	/* directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ */ baseName options.pathName
+				=	baseName options.pathName
+	# (closed, files)
+		=	fclose error files
+	| not closed
+		=	abort ("couldn't close error file \"" +++ options.errorPath +++ "\"\n")
+	=	(success, files)
\ No newline at end of file