diff options
| -rw-r--r-- | main/CleanCocl.icl | 24 | ||||
| -rw-r--r-- | main/Mac/CoclSystemDependent.dcl | 13 | ||||
| -rw-r--r-- | main/Mac/CoclSystemDependent.icl | 69 | ||||
| -rw-r--r-- | main/Version.dcl | 18 | ||||
| -rw-r--r-- | main/Version.icl | 32 | ||||
| -rw-r--r-- | main/Windows/Clean System Files/set_return_code.obj | bin | 0 -> 464 bytes | |||
| -rw-r--r-- | main/Windows/CoclSystemDependent.dcl | 14 | ||||
| -rw-r--r-- | main/Windows/CoclSystemDependent.icl | 15 | ||||
| -rw-r--r-- | main/Windows/set_return_code.dcl | 7 | ||||
| -rw-r--r-- | main/Windows/set_return_code.icl | 17 | ||||
| -rw-r--r-- | main/cocl.icl | 38 | ||||
| -rw-r--r-- | main/coclmain.dcl | 37 | ||||
| -rw-r--r-- | main/coclmain.icl | 63 | ||||
| -rw-r--r-- | main/compile.dcl | 5 | ||||
| -rw-r--r-- | main/compile.icl | 173 |
15 files changed, 525 insertions, 0 deletions
diff --git a/main/CleanCocl.icl b/main/CleanCocl.icl new file mode 100644 index 0000000..69915fd --- /dev/null +++ b/main/CleanCocl.icl @@ -0,0 +1,24 @@ +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) diff --git a/main/Mac/CoclSystemDependent.dcl b/main/Mac/CoclSystemDependent.dcl new file mode 100644 index 0000000..319b75c --- /dev/null +++ b/main/Mac/CoclSystemDependent.dcl @@ -0,0 +1,13 @@ +// 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 diff --git a/main/Mac/CoclSystemDependent.icl b/main/Mac/CoclSystemDependent.icl new file mode 100644 index 0000000..971105c --- /dev/null +++ b/main/Mac/CoclSystemDependent.icl @@ -0,0 +1,69 @@ +// 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) diff --git a/main/Version.dcl b/main/Version.dcl new file mode 100644 index 0000000..e70f420 --- /dev/null +++ b/main/Version.dcl @@ -0,0 +1,18 @@ +definition module Version + +:: VersionInfo = + { versionCurrent + :: Int + , versionOldestDefinition + :: Int + , versionOldestImplementation + :: Int + } + +:: VersionsCompatability + = VersionsAreCompatible + | VersionObservedIsTooOld + | VersionObservedIsTooNew + +versionCompare :: VersionInfo VersionInfo -> VersionsCompatability +// expected observed diff --git a/main/Version.icl b/main/Version.icl new file mode 100644 index 0000000..71ab761 --- /dev/null +++ b/main/Version.icl @@ -0,0 +1,32 @@ +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 diff --git a/main/Windows/Clean System Files/set_return_code.obj b/main/Windows/Clean System Files/set_return_code.obj Binary files differnew file mode 100644 index 0000000..d832506 --- /dev/null +++ b/main/Windows/Clean System Files/set_return_code.obj diff --git a/main/Windows/CoclSystemDependent.dcl b/main/Windows/CoclSystemDependent.dcl new file mode 100644 index 0000000..42cf82e --- /dev/null +++ b/main/Windows/CoclSystemDependent.dcl @@ -0,0 +1,14 @@ +// this is for Windows +definition module CoclSystemDependent + +// RWS split +// from deltaIOSystem import DeviceSystem +// from deltaEventIO import InitialIO, IOState + +PathSeparator + :== ';' +DirectorySeparator + :== '\\' + +SystemDependentDevices :: [a] +SystemDependentInitialIO :: [a] diff --git a/main/Windows/CoclSystemDependent.icl b/main/Windows/CoclSystemDependent.icl new file mode 100644 index 0000000..dc1d17b --- /dev/null +++ b/main/Windows/CoclSystemDependent.icl @@ -0,0 +1,15 @@ +// this is for Windows +implementation module CoclSystemDependent + +PathSeparator + :== ';' +DirectorySeparator + :== '\\' + +SystemDependentDevices :: [a] +SystemDependentDevices + = [] + +SystemDependentInitialIO :: [a] +SystemDependentInitialIO + = [] diff --git a/main/Windows/set_return_code.dcl b/main/Windows/set_return_code.dcl new file mode 100644 index 0000000..bcbde6f --- /dev/null +++ b/main/Windows/set_return_code.dcl @@ -0,0 +1,7 @@ +definition module set_return_code; + +from StdString import String; + +:: *UniqueWorld :== World; +set_return_code :: !Int !UniqueWorld -> UniqueWorld; +// void set_return_code (int return_code); diff --git a/main/Windows/set_return_code.icl b/main/Windows/set_return_code.icl new file mode 100644 index 0000000..780fa84 --- /dev/null +++ b/main/Windows/set_return_code.icl @@ -0,0 +1,17 @@ +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); diff --git a/main/cocl.icl b/main/cocl.icl new file mode 100644 index 0000000..15c62b4 --- /dev/null +++ b/main/cocl.icl @@ -0,0 +1,38 @@ +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\\" diff --git a/main/coclmain.dcl b/main/coclmain.dcl new file mode 100644 index 0000000..6366623 --- /dev/null +++ b/main/coclmain.dcl @@ -0,0 +1,37 @@ +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 diff --git a/main/coclmain.icl b/main/coclmain.icl new file mode 100644 index 0000000..811f76d --- /dev/null +++ b/main/coclmain.icl @@ -0,0 +1,63 @@ +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] diff --git a/main/compile.dcl b/main/compile.dcl new file mode 100644 index 0000000..f4c0953 --- /dev/null +++ b/main/compile.dcl @@ -0,0 +1,5 @@ +definition module compile + +from StdFile import Files + +compile :: [{#Char}] *Files -> (!Bool, !*Files) diff --git a/main/compile.icl b/main/compile.icl new file mode 100644 index 0000000..938ea8d --- /dev/null +++ b/main/compile.icl @@ -0,0 +1,173 @@ +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 |