Commit 01ad3ce0 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

Initial import

parent f20170de
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)
// 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
// 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)
definition module Version
:: VersionInfo =
{ versionCurrent
:: Int
, versionOldestDefinition
:: Int
, versionOldestImplementation
:: Int
}
:: VersionsCompatability
= VersionsAreCompatible
| VersionObservedIsTooOld
| VersionObservedIsTooNew
versionCompare :: VersionInfo VersionInfo -> VersionsCompatability
// expected observed
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
// this is for Windows
definition module CoclSystemDependent
// RWS split
// from deltaIOSystem import DeviceSystem
// from deltaEventIO import InitialIO, IOState
PathSeparator
:== ';'
DirectorySeparator
:== '\\'
SystemDependentDevices :: [a]
SystemDependentInitialIO :: [a]
// this is for Windows
implementation module CoclSystemDependent
PathSeparator
:== ';'
DirectorySeparator
:== '\\'
SystemDependentDevices :: [a]
SystemDependentDevices
= []
SystemDependentInitialIO :: [a]
SystemDependentInitialIO
= []
definition module set_return_code;
from StdString import String;
:: *UniqueWorld :== World;
set_return_code :: !Int !UniqueWorld -> UniqueWorld;
// void set_return_code (int return_code);
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);
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\\"
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
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]
definition module compile
from StdFile import Files
compile :: [{#Char}] *Files -> (!Bool, !*Files)
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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment