Commit 5ec77bbd authored by cvs2snv's avatar cvs2snv

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

parent 52fbeadd
This diff is collapsed.
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
Markdown is supported
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