packages feed

rail-compiler-editor 0.2.0.0 → 0.3.0.0

raw patch · 48 files changed

+7835/−3782 lines, 48 filesdep +cairodep +rail-compiler-editordep ~llvm-generalbinary-added

Dependencies added: cairo, rail-compiler-editor

Dependency ranges changed: llvm-general

Files

README.md view
@@ -69,7 +69,7 @@ 21 56 #-377+77 ```  **NOTE 1:** printed newlines have to be stated explicitly. Consider a hello-world@@ -106,8 +106,6 @@ input into the llvm-binary and compares the actual output with the current output. The result will be printed to stdout. -(TODO: do we have to run cabal first manually?)- ## Dependencies / Building the Compiler  - Install cabal (package cabal-install in most distributions)@@ -119,7 +117,7 @@ - `cabal test` to run the tests - Run the compiler with `dist/build/SWPSoSe14/SWPSoSe14 -c -i <Source.rail> -o output` - You still need to link the stack manually if you want to have executables:-  `llvm-link <compiled.ll> src/RailCompiler/stack.ll -o executable`+  `llvm-link <compiled.ll> src/RailCompiler/*.ll -o executable`  ## Documentation
+ data/icon.png view

binary file changed (absent → 3781 bytes)

rail-compiler-editor.cabal view
@@ -1,5 +1,5 @@ name: rail-compiler-editor-version:             0.2.0.0+version:             0.3.0.0 synopsis: Compiler and editor for the esolang rail. description: A compiler and a graphical editor for the esoteric programming language rail. homepage:            https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14@@ -11,56 +11,80 @@ -- copyright: category:            Language build-type:          Simple-extra-source-files:  README.md, tests/integration_tests, src/RailCompiler/stack.ll+extra-source-files:  README.md, tests/integration_tests, src/RailCompiler/stack.ll, src/RailCompiler/cmp.ll, src/RailCompiler/math.ll, src/RailCompiler/string.ll src/RailCompiler/linked_stack.ll src/RailCompiler/list.ll+data-files: data/icon.png cabal-version:       >=1.10  source-repository head   type: git   location: https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14.git -executable RailCompiler-  main-is: Main.hs-  other-modules:+library+  build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers+  ghc-prof-options: -fprof-auto+  exposed-modules:+    AST     Backend-    CodeOptimization     ErrorHandling+    InstructionPointer     InterfaceDT     IntermediateCode     Lexer     Preprocessor     SemanticalAnalysis     SyntacticalAnalysis+    FunctionDeclarations+    TypeDefinitions+  hs-source-dirs: src/RailCompiler+  default-language: Haskell2010++executable RailCompiler+  main-is: Main.hs+  build-depends: base (>=4.5.0.0 && <5), rail-compiler-editor+  ghc-options: -rtsopts+  ghc-prof-options: -fprof-auto   --other-extensions:    DeriveDataTypeable, GADTs, StandaloneDeriving-  build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers+  --build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers    -- Directories containing source files.-  hs-source-dirs: src/RailCompiler+  hs-source-dirs: src/RailCompiler-command    -- Base language which the package is written in.   default-language:    Haskell2010  executable RailEditor-  main-is: Main.hs+  main-is: Editor.hs+  ghc-prof-options: -fprof-auto   other-modules:-    EditorBackend+    FooterBar+    Highlighter+    InteractionField+    Interpreter+    KeyHandler+    MainWindow+    MenuBar     Execute-    Menu+    RedoUndo+    TextAreaContent+    Selection+    TextAreaContentUtils     TextArea-  build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general < 3.4.3, mtl, containers, transformers, gtk, process-  hs-source-dirs: src/RailEditor src/RailCompiler+    ToolBar+    Paths_rail_compiler_editor+  build-depends: base (>=4.5.0.0 && <5), containers, transformers, gtk, cairo, process, mtl, rail-compiler-editor+  hs-source-dirs: src/RailEditor   default-language: Haskell2010  Test-suite testcases   main-is: Main.hs   other-modules:     TBackend-    TCodeOpt     TInterCode     TLexer     TPreProc     TSemAna     TSynAna-  build-depends: base (>=4.5.0.0 && <5), HUnit, llvm-general-pure, llvm-general < 3.4.3, mtl, containers, process-  hs-source-dirs: tests, src/RailCompiler+  build-depends: base (>=4.5.0.0 && <5), HUnit, rail-compiler-editor, process, containers+  hs-source-dirs: tests   default-language: Haskell2010   type: exitcode-stdio-1.0
+ src/RailCompiler-command/Main.hs view
@@ -0,0 +1,116 @@+{- |+Module      : Main.hs+Description : .+Maintainer  : (c) Christopher Pockrandt, Nicolas Lehmann, Tobias Kranz+License     : MIT++Stability   : stable++Entrypoint of the rail2llvm-compiler. Contains main-function.++See also:+--https://www.haskell.org/ghc/docs/7.8.2/html/libraries/base-4.7.0.0/System-Console-GetOpt.html+--http://leiffrenzel.de/papers/commandline-options-in-haskell.html (Outdated!)++-}+module Main( main ) where++-- imports --+import System.Environment+import System.Exit+import System.Console.GetOpt+import Data.Maybe( fromMaybe )+import InterfaceDT                   as IDT+import qualified Preprocessor        as PreProc+import qualified Lexer+import qualified SyntacticalAnalysis as SynAna+import qualified SemanticalAnalysis  as SemAna+import qualified IntermediateCode    as InterCode+import qualified Backend++-- defining the option settings for the main-function+data Options = Options  {+    optInput     :: IO String,+    optOutput    :: String -> IO (),+    optASTOutput :: String -> IO (),+    compile      :: Bool,+    impAST       :: Bool,+    expAST       :: Bool+  }++-- default Options+defaultOptions :: Options+defaultOptions   = Options {+    optInput     = getContents,+    optOutput    = putStr,+    optASTOutput = putStr,+    compile      = False,+    impAST       = False,+    expAST       = False+    +  }++-- usageInfo+options :: [OptDescr (Options -> IO Options)]+options = [+    --Option ['V'] ["version"] (NoArg  showVersion)      "show version number",+    Option "h" ["help"     ] (NoArg  showHelp         ) "display Help Text",+    Option "i" ["input"    ] (ReqArg setInput  "FILE" ) "input file (don't set to use stdin')",+    Option "o" ["output"   ] (ReqArg setOutput "FILE" ) "output file (don't set to use stdout')",+    Option "c" ["compile"  ] (NoArg  setCompile       ) "compile 'rail' to 'llvm'",+    Option [ ] ["exportAST"] (OptArg setExpAST "FILE" ) "export frontend AST (don't offer a File to use stdout) \n(dont set with --importAST)",+    Option [ ] ["importAST"] (NoArg setImpAST         ) "import frontend AST and compile to llvm\nautosets -c \n(set input via -i; (dont set with --exportAST)\n\nset -c with --exportAST and get both: the AST and the llvm code"    +  ]++-- output for the help-function+showHelp _ = do+  putStrLn "rail2llvm--haskell-compiler (development version)"+  putStr "https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14\n\n"+  putStr $ usageInfo "Usage: main [OPTION...]" options  +  exitSuccess++-- options-getter for optional output for exprotAST+getOut (Just arg) = writeFile arg+getOut Nothing = putStr++-- options-setters+setInput  arg opt = return opt { optInput     = readFile arg }+setOutput arg opt = return opt { optOutput    = writeFile arg }+setExpAST arg opt = return opt { optASTOutput = getOut arg, expAST = True}+setImpAST     opt = return opt { impAST       = True, compile = True }+setCompile    opt = return opt { compile      = True }++-- main-function --+main = do args <- getArgs+          let (actions,nonOpts,msgs) = getOpt RequireOrder options args+          -- intercept errors+          if msgs /= []+          then error $ concat msgs ++ usageInfo "Usage: main [OPTION...]" options+          -- unrecognized arguments error+          else if nonOpts /= [] +            then error $ "unrecognized arguments: " ++ unwords nonOpts ++ "\nUsage: For basic information, try the `--help' option."+            else do opts <- foldl (>>=) (return defaultOptions) actions+                    -- option aliases+                    let Options { optInput = input, optOutput = output,  optASTOutput = outputAST, compile = cmpl, impAST = imp, expAST = exp} = opts+                    inputWithoutIO <- input+                    -- importAST and exportAST can't be set together (error)+                    if imp && exp +                    then do error "No export of the imported AST (Usage: For basic information, try the `--help' option.)'"+                            exitSuccess+                    -- compile a file+                    else if cmpl +                         then do let transform (IBO x) = x+                                 -- compile an imported AST to a LLVM-file+                                 if imp+                                 then transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.toAST $ inputWithoutIO) >>= output+                                 -- compile a RAIL-file to an AST as an export-file+                                 else if exp+                                      then do outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO)+                                              transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output+                                      -- compile a RAIL-file to a LLVM-file+                                      else transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output+                         -- exportAST (without compiling it to llvm)+                         else if exp+                              then outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO)+                              -- missing argument error+                              else error "Error. Set atleast -c or --importAST or --exportAST."
+ src/RailCompiler/AST.hs view
@@ -0,0 +1,348 @@+{- |+Module      : Abstract Syntax Tree+Description : Helper module for Lexer which cares about everything related to the interchageable AST.+Maintainer  : Christian H. et al.+License     : MIT+-}+module AST (fromAST, toAST, parse, adjacent, valids)+ where++ import InterfaceDT as IDT+ import ErrorHandling as EH+ import Data.Maybe+ import Data.List+ import Text.Printf+ import qualified Data.Map as Map+ import InstructionPointer++ -- |Convert a graph/AST into a portable text representation.+ -- See also 'fromGraph'.+ fromAST :: IDT.Lexer2SynAna -- ^Input graph/AST/forest.+    -> String -- ^Portable text representation of the AST:+              --+              -- Each function is represented by its own section. A section has a header+              -- and content; it continues either until the next section, a blank line or+              -- the end of the file, whichever comes first.+              --+              -- A section header consists of a single line containing the name of the function,+              -- enclosed in square brackets, e. g. @[function_name]@. There cannot be any whitespace+              -- before the opening bracket.+              --+              -- The section content consists of zero or more non-blank lines containing exactly+              -- three records delimited by a semicolon @;@. Each line describes a node and contains+              -- the following records, in this order:+              --+              --     * The node ID (numeric), e. g. @1@.+              --     * The Rail lexeme, e. g. @o@ or @[constant]@ etc. Note that track lexemes like+              --     @-@ or @+@ are not included in the graph. Multi-character lexemes like constants+              --     may include semicolons, so you need to parse them correctly! In other words, you need+              --     to take care of lines like @1;[some ; constant];2@.+              --     * Node ID of the follower node, e. g. @2@. May be @0@ if there is no next node.+ fromAST (IDT.ILS graph) = unlines $ map fromGraph graph++ -- |Convert a portable text representation of a graph into a concrete graph representation.+ -- See also 'toGraph'. See 'fromAST' for a specification of the portable text representation.+ toAST :: String -- ^Portable text representation. See 'fromAST'.+    -> IDT.Lexer2SynAna -- ^Output graph.+ toAST input = IDT.ILS (map toGraph $ splitfunctions input)++ -- |Convert an 'IDT.Graph' for a single function to a portable text representation.+ -- See 'fromAST' for a specification of the representation.+ --+ -- TODO: Currently, this apparently crashes the program on invalid input. More sensible error handling?+ --       At least a nice error message would be nice.+ fromGraph :: IDT.Graph -- ^Input graph.+    -> String -- ^Text representation.+ fromGraph (funcname, nodes) = unlines $ ("["++funcname++"]"):tail (map (fromLexNode . offset (-1)) nodes)+  where+   fromLexNode :: IDT.LexNode -> String+   fromLexNode (id, lexeme, follower) = show id ++ ";" ++ fromLexeme lexeme ++ ";" ++ show follower ++ optional lexeme+   fromLexeme :: IDT.Lexeme -> String+   fromLexeme Boom = "b"+   fromLexeme EOF = "e"+   fromLexeme Input = "i"+   fromLexeme Output = "o"+   fromLexeme Underflow = "u"+   fromLexeme RType = "?"+   fromLexeme (Constant string) = "["++escapestring string++"]"+   fromLexeme (Push string) = "("++string++")"+   fromLexeme (Pop string) = "(!"++string++"!)"+   fromLexeme (Call string) = "{"++string++"}"+   fromLexeme Add1 = "a"+   fromLexeme Divide = "d"+   fromLexeme Multiply = "m"+   fromLexeme Remainder = "r"+   fromLexeme Subtract = "s"+   fromLexeme Cut = "c"+   fromLexeme Append = "p"+   fromLexeme Size = "z"+   fromLexeme Nil = "n"+   fromLexeme Cons = ":"+   fromLexeme Breakup = "~"+   fromLexeme Greater = "g"+   fromLexeme Equal = "q"+   fromLexeme Start = "$"+   fromLexeme Finish = "#"+   fromLexeme (Junction _) = "v"+   fromLexeme (Lambda _) = "&"+   fromLexeme NOP = "."+   optional (Junction follow) = ';' : show follow+   optional (Lambda follow) = ';' : show follow+   optional _ = ";0"++ -- |Split a portable text representation of multiple function graphs (a forest) into separate+ -- text representations of each function graph.+ splitfunctions :: String -- ^Portable text representation of the forest.+    -> [[String]] -- ^List of lists, each being a list of lines making up a separate function graph.+ splitfunctions = groupBy (\_ y -> null y || head y /= '[') . filter (not . null) . lines++ -- |Convert a portable text representation of a single function into an 'IDT.Graph'.+ -- Raises 'error's on invalid input (see 'ErrorHandling').+ toGraph :: [String] -- ^List of lines making up the text representation of the function.+    -> IDT.Graph -- ^Graph describing the function.+ toGraph lns = (init $ tail $ head lns, (1, Start, if null nodelist then 0 else 2):map (offset 1) nodelist)+  where+   nodelist = nodes $ tail lns+   nodes [] = []+   nodes (ln:lns) = (read id, fixedlex, read follower):nodes lns+    where+     (id, other) = span (/=';') ln+     (lex, ip) = parse (convert [other]) (IP 0 1 0 E Forward Map.empty)+     (follower, attribute) = span (/=';') (drop (2 + posx ip) other)+     fixedlex+      | isJunction lex = Junction (read $ tail attribute)+      | isLambda lex = Lambda (read $ tail attribute)+      | otherwise = fromJust lex+     fromJust Nothing = error $ printf EH.shrLineNoLexeme ln+     fromJust (Just x) = x+     isJunction (Just (Junction _)) = True+     isJunction _ = False+     isLambda (Just (Lambda _)) = True+     isLambda _ = False+     convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code)++ -- |Shift a node by the given amount. May be positive or negative.+ -- This is used by 'toGraph' and 'fromGraph' to shift all nodes by 1 or -1, respectively,+ -- which is done because the portable text representation of the graph does not include+ -- a leading "Start" node with ID 1 -- instead, the node with ID 1 is the first "real"+ -- graph node. In other words, when exporting to the text representation, the "Start"+ -- node is removed and all other nodes are "shifted" by -1 using this function. When+ -- importing, a "Start" node is added and all nodes are shifted by 1.+ offset :: Int -- ^Amount to shift node by.+    -> IDT.LexNode -- ^Node to operate on.+    -> IDT.LexNode -- ^Shifted node.+ offset c (node, lexeme, 0) = (node + c, lexeme, 0)+ offset c (node, lexeme, following) = (node + c, lexeme, following + c)++ -- |Get adjacent (left secondary, primary, right secondary)+ -- symbols for the current IP position.+ adjacent :: IDT.Grid2D -- ^Line representation of the current function.+     -> IP -- ^Current instruction pointer.+     -> (Char, Char, Char) -- ^Adjacent (left secondary, primary, right secondary) symbols+ adjacent code ip+  | current code ip `elem` turnblocked = (' ', charat code (posdir ip Forward), ' ')+  | otherwise = (charat code (posdir ip InstructionPointer.Left), charat code (posdir ip Forward), charat code (posdir ip InstructionPointer.Right))++ -- |Get the next lexeme at the current position.+ parse :: IDT.Grid2D -- ^Line representation of current function.+    -> IP -- ^Current instruction pointer.+    -> (Maybe IDT.Lexeme, IP) -- ^Resulting lexeme (if any) and+                              -- the new instruction pointer.+ parse code ip = junctioncheck $ case current code ip of+   'b' -> (Just Boom, ip)+   'e' -> (Just EOF, ip)+   'i' -> (Just Input, ip)+   'o' -> (Just Output, ip)+   'u' -> (Just Underflow, ip)+   '?' -> (Just RType, ip)+   'a' -> (Just Add1, ip)+   'd' -> (Just Divide, ip)+   'm' -> (Just Multiply, ip)+   'r' -> (Just Remainder, ip)+   's' -> (Just Subtract, ip)+   '0' -> (Just (Constant "0"), ip)+   '1' -> (Just (Constant "1"), ip)+   '2' -> (Just (Constant "2"), ip)+   '3' -> (Just (Constant "3"), ip)+   '4' -> (Just (Constant "4"), ip)+   '5' -> (Just (Constant "5"), ip)+   '6' -> (Just (Constant "6"), ip)+   '7' -> (Just (Constant "7"), ip)+   '8' -> (Just (Constant "8"), ip)+   '9' -> (Just (Constant "9"), ip)+   'c' -> (Just Cut, ip)+   'p' -> (Just Append, ip)+   'z' -> (Just Size, ip)+   'n' -> (Just Nil, ip)+   ':' -> (Just Cons, ip)+   '~' -> (Just Breakup, ip)+   'f' -> (Just (Constant "0"), ip)+   't' -> (Just (Constant "1"), ip)+   'g' -> (Just Greater, ip)+   'q' -> (Just Equal, ip)+   '$' -> (Just Start, ip)+   '#' -> (Just Finish, ip)+   '.' -> (Just NOP, ip)+   'v' -> (Just (Junction 0), ip)+   '^' -> (Just (Junction 0), ip)+   '>' -> (Just (Junction 0), ip)+   '<' -> (Just (Junction 0), ip)+   '&' -> (Just (Lambda 0), ip)+   '[' -> let (string, newip) = readconstant code tempip '[' ']' in (Just (Constant string), newip)+   ']' -> let (string, newip) = readconstant code tempip ']' '[' in (Just (Constant string), newip)+   '{' -> let (string, newip) = stepwhile code tempip (/= '}') in (Just (Call $ checkstring string), newip)+   '}' -> let (string, newip) = stepwhile code tempip (/= '{') in (Just (Call $ checkstring string), newip)+   '(' -> let (string, newip) = stepwhile code tempip (/= ')') in (pushpop string, newip)+   ')' -> let (string, newip) = stepwhile code tempip (/= '(') in (pushpop string, newip)+   _ -> (Nothing, turn (current code ip) ip)+  where+   junctioncheck (Nothing, ip)+     | current code ip `elem` "+x*" && next code ip `elem` "v^<>" = (Nothing, crashfrom ip)+--     | forward == ' ' && (left == current code ip || right == current code ip) = (Nothing, crashfrom ip)+     | forward == ' ' && (left `elem` "v^<>+x*" || right `elem` "v^<>+x*") = (Nothing, crashfrom ip)+     | otherwise = (Nothing, ip)+    where+     (left, forward, right) = adjacent code ip+   junctioncheck (lexeme, ip)+    | next code ip `elem` "v^<>" = (lexeme, crashfrom ip)+    | otherwise = (lexeme, ip)+   tempip = move ip Forward+   checkstring string = if '!' `elem` string then error EH.strInvalidVarName else string+   pushpop string+    | length string < 2 = Just (Push $ checkstring string)+    | head string == '!' && last string == '!' = Just (Pop (checkstring $ tail $ init string))+		| otherwise = Just (Push $ checkstring string)++ -- |Collect characters until a condition is met while moving in the current direction.+ stepwhile :: IDT.Grid2D -- ^Line representation of current function.+    -> IP -- ^Current instruction pointer.+    -> (Char -> Bool) -- ^Function: Should return True if collection should stop.+                      -- Gets the current Char as an argument.+    -> (String, IP) -- ^Collected characters and the new instruction pointer.+ stepwhile code ip fn+   | not (fn curchar) = ("", ip)+   | not (moveable code ip Forward) = error EH.strMissingClosingBracket+   | curchar `elem` "'{}()" = error EH.strInvalidVarName+   | otherwise = (curchar:resstring, resip)+  where+   curchar = current code ip+   (resstring, resip) = stepwhile code (move ip Forward) fn++ -- |Checks if the instruction pointer can be moved without leaving the grid+ moveable :: IDT.Grid2D -- ^Line representation of current function+    -> IP -- ^Current instruction pointer+    -> RelDirection -- ^Where to move to+    -> Bool -- ^Whether or not the move could be made+ moveable code ip reldir+   | Map.size code == 0 = False+   | isNothing (Map.lookup newy code) = False+   | dir ip `elem` [W, E] && isNothing (Map.lookup newx line) = False+   | otherwise = True+  where+   (newy, newx) = posdir ip reldir+   line = fromJust (Map.lookup newy code)++ -- |Read a string constant and handle escape sequences like \n.+ -- Raises an error on invalid escape sequences and badly formatted constants.+ readconstant :: IDT.Grid2D -- ^Current function in line representation+    -> IP -- ^Current instruction pointer+    -> Char -- ^Opening string delimiter, e. g. '['+    -> Char -- ^Closing string delimiter, e. g. ']'+    -> (String, IP) -- ^The processed constant and the new instruction pointer+ readconstant code ip startchar endchar+    | curchar == startchar  = error EH.strNestedOpenBracket+    | curchar == endchar    = ("", ip)+    | not (moveable code ip Forward) = error EH.strMissingClosingBracket+    | otherwise             = (newchar:resstring, resip)+  where+    curchar                 = current code ip+    (newchar, newip)        = processescape+    (resstring, resip)      = readconstant code newip startchar endchar++    -- This does the actual work and converts the escape sequence+    -- (if there is no escape sequence at the current position, do+    -- nothing and pass the current Char through).+    processescape :: (Char, IP)+    processescape+        | curchar /= '\\'   = (curchar, move ip Forward)+        | curchar == '\\' && escsym == '\\' = ('\\', skip code ip 2)+        | esctrail /= '\\'  = error EH.strNonSymmetricEscape+        | otherwise         = case escsym of+            '['  -> ('[', escip)+            ']'  -> (']', escip)+            'n'  -> ('\n', escip)+            't'  -> ('\t', escip)+            _    -> error $ printf EH.strUnhandledEscape escsym+      where+        [escsym, esctrail]  = lookahead code ip 2+        -- Points to the character after the trailing backslash+        escip               = skip code ip 3++ escapestring :: String -> String+ escapestring [] = []+ escapestring (x:xs) = newx ++ escapestring xs+   where+     newx = case x of+       '\\' -> "\\\\"+       '\n' -> "\\n\\"+       '[' -> "\\[\\"+       ']' -> "\\]\\"+       '\t' -> "\\t\\"+       _ -> [x]++ -- |Lookahead n characters in the current direction.+ lookahead :: IDT.Grid2D -- ^Line representation of current function+    -> IP -- ^Current instruction pointer+    -> Int -- ^How many characters of lookahead to produce?+    -> String -- ^n characters of lookahead+ lookahead code ip 0 = []+ lookahead code ip n = current code newip : lookahead code newip (n-1)+  where+    newip = move ip Forward++ -- |Skip n characters in the current direction and return the new IP.+ skip :: IDT.Grid2D -- ^Line representation of current function+    -> IP -- ^Current instruction pointer+    -> Int  -- ^How many characters to skip? If 1, this is the same+            -- as doing "move ip Forward".+    -> IP -- ^New instruction pointer+ skip code ip n = foldl (\x _ -> move x Forward) ip [1..n]++ -- |Get the 'Char' at the next position of the instruction pointer+ next :: IDT.Grid2D -> IP -> Char+ next code ip = current code $ move ip Forward++ -- |Return valid chars for movement depending on the current direction.+ valids :: IDT.Grid2D -- ^Line representation of current function.+    -> IP -- ^Current instruction pointer.+    -> (String, String, String) -- ^Tuple consisting of:+                                --+                                --     * Valid characters for movement to the (relative) left.+                                --     * Valid characters for movement in the (relative) forward direction.+                                --     * Valid characters for movement to the (relative) right.+ valids code ip = tripleinvert (secinv code ip InstructionPointer.Left, finvalid ip, secinv code ip InstructionPointer.Right)+  where+   secinv code ip direction = [current code ip] ++ commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip direction}+   tripleinvert (l, f, r) = (filter (`notElem` l) everything, filter (`notElem` f) everything, filter (`notElem` r) everything)+   finvalid ip = dirinvalid ip ++ crossinvalid ip -- illegal to move forward+   dirinvalid ip -- illegal without crosses+    | dir ip `elem` [E, W] = "|"+    | dir ip `elem` [NE, SW] = "\\"+    | dir ip `elem` [N, S] = "-"+    | dir ip `elem` [NW, SE] = "/"+    | otherwise = ""+   crossinvalid ip -- illegal crosses+    | dir ip `elem` [N, E, S, W] = "x"+    | otherwise = "+"+   cur = current code ip+   everything = "+\\/x|-" ++ always+   always = "^v<>*@{}[]()" ++ commandchars+ + -- list of chars that are commands in rail+ commandchars :: String+ commandchars = "abcdefgimnopqrstuz:~0123456789?#&"++ -- list of chars which do not allow any turning+ turnblocked :: String+ turnblocked = "$*+x" ++ commandchars+-- vim:ts=2 sw=2 et
src/RailCompiler/Backend.hs view
@@ -1,8 +1,7 @@ {- | Module      : Backend Description : Converts the internal LLVM representation into textual LLVM IR.-Maintainer  : See the AUTHORS file in the root directory of this project for a list-              of contributors.+Maintainer  : Tilman Blumenbach, Nicolas Lehmann, Philipp Borgers License     : MIT  Uses the LLVM bindings for Haskell to convert the internal LLVM representation@@ -16,30 +15,25 @@ where  -- imports ---import InterfaceDT as IDT import ErrorHandling as EH+import InterfaceDT as IDT +import Control.Monad.Error import LLVM.General.AST-import qualified LLVM.General.AST as AST+import LLVM.General.AST.Global import LLVM.General.Context import LLVM.General.Module-import Control.Monad.Error-import LLVM.General.AST.Global-+import qualified LLVM.General.AST as AST  -- functions -- -- |Converts the internal LLVM representation into textual LLVM IR.-process :: IDT.CodeOpt2Backend -> IDT.Backend2Output-process input = output-  where-    output = IDT.IBO $ generateOutput input+process :: IDT.InterCode2Backend -> IDT.Backend2Output+process input = IDT.IBO $ generateOutput input  -- |Uses the Haskell LLVM bindings to convert the internal LLVM -- representation into textual LLVM IR.-generateOutput :: IDT.CodeOpt2Backend -> IO String-generateOutput (IDT.ICB mod) = do+generateOutput :: IDT.InterCode2Backend -> IO String+generateOutput (IDT.IIB mod) = do   s <- withContext $ \context ->     runErrorT $ withModuleFromAST context mod $ \m -> moduleLLVMAssembly m-  case s of-    Left err -> return err-    Right ll -> return ll+  either error return s
− src/RailCompiler/CodeOptimization.hs 
@@ -1,23 +0,0 @@-{- |-Module      : CodeOptimization.hs-Description : .-Maintainer  : Christopher Pockrandt-License     : MIT--This module might be used for optimizing intermediate llvm code one day (or not).-Until then, `process` equals the identity function.---}module CodeOptimization (-                         process   -- main function of the module "CodeOptimization"-					    )- where- - -- imports --- import InterfaceDT as IDT- import ErrorHandling as EH- - -- functions --- process :: IDT.InterCode2CodeOpt -> IDT.CodeOpt2Backend- process (IDT.IIC input) = IDT.ICB output-  where-   output = input
src/RailCompiler/ErrorHandling.hs view
@@ -24,6 +24,8 @@ strNonSymmetricEscape   = "Non-symmetric escape sequence in string constant." strUnhandledEscape      = "Unhandled escape sequence `\\%c' in string constant." strMissingClosingBracket= "Closing Bracket not found."+strInvalidVarName       = "Invalid Variable Name used."+strInvalidFuncName      = "Invalid Function Name used."  -- "shr" like in "shared graph representation". shrLineNoLexeme         = "No lexeme found in line: %s"@@ -33,9 +35,10 @@ -- SemanticalAnalysis-Errors strInvalidMovement      = "Invalid movement." strMainMissing          = "No 'main' Method found."+strUnknownNode          = "Unknown Node in AST."+strEmptyProgram         = "Empty Program."+strDuplicateFunctions   = "Duplicate Functions found."  -- IntermediateCode-Errors---- CodeOptimization-Errors  -- Backend
+ src/RailCompiler/FunctionDeclarations.hs view
@@ -0,0 +1,320 @@+{- |+Module      :  FunctionDeclarations.hs+Description :  Function declarations for intermediate code generation+Maintainer  :  Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke,+               Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu+License     :  MIT+Stability   :  unstable++All function declarations live here.++-}++module FunctionDeclarations where++import LLVM.General.AST.AddrSpace+import LLVM.General.AST+import qualified LLVM.General.AST.Global as Global++import TypeDefinitions++-- |Function declaration for 'start'.+start :: Definition+start = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "start",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'underflow_check'.+underflowCheck :: Definition+underflowCheck = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "underflow_check",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'print'.+print :: Definition+print = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "print",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'crash'.+crash :: Definition+crash = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "crash",+  Global.returnType = VoidType,+  Global.parameters = ([ Parameter (IntegerType 1) (Name "is_custom_error") [] ], False)+}++-- |Function declaration for 'finish'.+finish :: Definition+finish = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "finish",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'input'.+inputFunc :: Definition+inputFunc = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "input",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'eof_check'.+eofCheck :: Definition+eofCheck = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "eof_check",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'add'.+add :: Definition+add = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "add",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'rem'.+rem1 :: Definition+rem1 = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "rem",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'sub'.+sub :: Definition+sub = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "sub",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'mul'.+mul :: Definition+mul = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "mult",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'div'.+div1 :: Definition+div1 = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "div",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'type'.+type1 :: Definition+type1 = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "type",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for pushing constants.+pushStringCpy :: Definition+pushStringCpy = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "push_string_cpy",+  Global.returnType = stackElementPointerType,+  Global.parameters = ([ Parameter bytePointerType (UnName 0) [] ], False)+}++-- |Function declaration for 'pop'.+pop :: Definition+pop = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "pop",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'peek'+peek :: Definition+peek = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "peek",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'streq'+streq :: Definition+streq = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "streq",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'strlen'+strlen :: Definition+strlen = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "strlen",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'strapp'+strapp :: Definition+strapp = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "strapp",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'strcut'.+strcut :: Definition+strcut = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "strcut",+  Global.returnType = bytePointerType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'pop_int'+popInt :: Definition+popInt = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "pop_int",+  Global.returnType = IntegerType 64,+  Global.parameters = ([], False)+}++-- |Function declaration for 'pop_bool'+popBool :: Definition+popBool = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "pop_bool",+  Global.returnType = IntegerType 64,+  Global.parameters = ([], False)+}++-- |Function declaration for 'equal'+equal :: Definition+equal = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "equal",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'greater'+greater :: Definition+greater = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "greater",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for 'pop_into'+popInto :: Definition+popInto = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "pop_into",+  Global.returnType = VoidType,+  Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name  +    "struct.table") (AddrSpace 0)) (UnName 0) [], +    Parameter bytePointerType (UnName 0) [] ], False)+}++-- |Function declaration for 'push_from'+pushFrom :: Definition+pushFrom = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "push_from",+  Global.returnType = VoidType,+  Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name  +    "struct.table") (AddrSpace 0)) (UnName 0) [], +    Parameter bytePointerType (UnName 0) [] ], False)+}++-- |Function declaration for initialising of the symbol table+initialiseSymbolTable :: Definition+initialiseSymbolTable = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "initialise",+  Global.returnType = VoidType,+  Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ +    Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False)+}++-- |Function declaration for malloc+malloc :: Definition+malloc = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "malloc",+  Global.returnType = bytePointerType,+  Global.parameters = ([ Parameter (IntegerType 64) (UnName 0) [] ], False)+}++-- |Function declaration for copying of the symbol table+copySymbolTable :: Definition+copySymbolTable = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "copy_symbol_table",+  Global.returnType = VoidType,+  Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ +    Name "struct.table") (AddrSpace 0)) (UnName 0) [],+    Parameter (PointerType (NamedTypeReference $ +    Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False)+}++-- |Function declaration for pushing lambda+pushLambda :: Definition+pushLambda = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "push_lambda",+  Global.returnType = VoidType,+  Global.parameters = ([ Parameter (PointerType (+    PointerType functionReturnLambda (AddrSpace 0)) (AddrSpace 0)) (UnName 0) [],+    Parameter (PointerType (NamedTypeReference $ +    Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False)+}++-- |Function declaration for popping a lambda element+popLambda :: Definition+popLambda = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "pop_lambda",+  Global.returnType = PointerType (NamedTypeReference $ Name "lambda_element") (AddrSpace 0),+  Global.parameters = ([], False)+}++-- |Function declaration for getting a pointer to a lambda function+getLambda :: Definition+getLambda = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "get_lambda_pointer",+  Global.returnType = PointerType functionReturnLambda (AddrSpace 0),+  Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ +    Name "lambda_element") (AddrSpace 0)) (UnName 0) [] ], False)+}++-- |Function declaration for getting lambda symbol table+getTable :: Definition+getTable = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "get_lambda_table",+  Global.returnType = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0),+  Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ +    Name "lambda_element") (AddrSpace 0)) (UnName 0) [] ], False)+}++-- |Function declaration for pushing nil onto the stack.+listPushNil :: Definition+listPushNil = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "gen_list_push_nil",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for list cons.+listCons :: Definition+listCons = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "gen_list_cons",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}++-- |Function declaration for list breakup.+listBreakup :: Definition+listBreakup = GlobalDefinition $ Global.functionDefaults {+  Global.name = Name "gen_list_breakup",+  Global.returnType = VoidType,+  Global.parameters = ([], False)+}
+ src/RailCompiler/InstructionPointer.hs view
@@ -0,0 +1,215 @@+{- |+Module      : Instruction Pointer+Description : Helper module for Lexer to actually move on code.+Maintainer  : Christian H. et al.+License     : MIT+-}+module InstructionPointer (+                           -- constructors+                           start, crash, crashfrom, ipmerge, IP(IP),+                           RelDirection(Left, Right, Forward),+                           Direction (N, NE, E, SE, S, SW, W, NW),+                           -- movement+                           junctionturns, lambdadirs, move, turnaround, +                           -- attribute/pseudoattribute functions+                           dir, nodecount, posx, posy, count, path, visited,+                           -- other+                           posdir, absolute, nodeadd, turn, current, charat+                          )+ where++ import InterfaceDT as IDT+ import Data.Maybe+ import qualified Data.Map as Map++ -- |An absolute direction.+ data Direction = N | NE | E | SE | S | SW | W | NW deriving (Ord, Eq, Show)+ -- |A relative direction.+ data RelDirection = Left | Forward | Right deriving (Eq, Show)+ -- |Instruction pointer consisting of position and an orientation.+ data IP =+    IP {+      -- |Number of processed characters since start of current function.+      count :: Int,+      -- |Current X position.+      posx :: Int,+      -- |Current Y position.+      posy :: Int,+      -- |Current 'Direction'.+      dir :: Direction,+			-- |Determines if the instruction pointer is on a left or right path of a Junction+			path :: RelDirection,+      -- |Map of Position and Direction to Id+      known :: Map.Map (Int, Int, Direction) Int+    }+  deriving (Show)++ instance Eq IP+  where+   (==) ipl ipr = posx ipl == posx ipr && posy ipl == posy ipr && dir ipl == dir ipr++ -- |Initial value for the instruction pointer at the start of a function.+ start :: IP+ start = IP 0 0 0 SE Forward (Map.singleton (0, 0, SE) 1)++ -- |An instruction pointer representing a "crash" (fatal error).+ crash :: IP+ crash = IP 0 (-1) (-1) NW Forward Map.empty++ crashfrom :: IP -> IP+ crashfrom = ipmerge crash++ ipmerge :: IP -> IP -> IP+ ipmerge ipl ipr = ipl{known = known ipr}++ turn :: Char -> IP -> IP+ turn '@' ip = turnaround ip+ turn '|' ip+	| dir ip `elem` [NW, N, NE] = ip{dir = N}+	| dir ip `elem` [SW, S, SE] = ip{dir = S}+ turn '/' ip+	| dir ip `elem` [N, NE, E] = ip{dir = NE}+	| dir ip `elem` [S, SW, W] = ip{dir = SW}+ turn '-' ip+	| dir ip `elem` [NE, E, SE] = ip{dir = E}+	| dir ip `elem` [SW, S, NW] = ip{dir = W}+ turn '\\' ip+	| dir ip `elem` [W, NW, N] = ip{dir = NW}+	| dir ip `elem` [E, SE, S] = ip{dir = SE}+ turn _ ip = ip++ -- |Move the instruction pointer in a relative direction.+ move :: IP -- ^Current instruction pointer.+    -> RelDirection -- ^Relative direction to move in.+    -> IP -- ^New instruction pointer.+ move ip reldir = ip{count = newcount, posx = newx, posy = newy, dir = absolute ip reldir}+  where+   (newy, newx) = posdir ip reldir+   newcount = count ip + 1++ -- |Get the 'Char' at the current position of the instruction pointer.+ current :: IDT.Grid2D -- ^Line representation of the current function.+     -> IP -- ^Current instruction pointer.+     -> Char -- ^'Char' at the current IP position.+ current code ip = charat code (posy ip, posx ip)++ -- |Returns 'Char' at given position, @\' \'@ if position is invalid.+ charat :: IDT.Grid2D -- ^Line representation of current function.+    -> (Int, Int) -- ^Position as (x, y) coordinate.+    -> Char -- ^'Char' at given position.+ charat code _ | Map.size code == 0 = ' '+ charat code (y, _) | isNothing (Map.lookup y code) = ' '+ charat code (y, x)+   | isNothing (Map.lookup x line) = ' '+   | otherwise = fromJust (Map.lookup x line)+  where+   line = fromJust (Map.lookup y code)++ -- returns instruction pointers turned for (False, True)+ junctionturns :: IDT.Grid2D -> IP -> (IP, IP)+ junctionturns code ip = tuplecheck $ tuplemove $ addpath $ turning (current code ip) ip+  where+   check ip = if current code ip == primary ip then ip else crashfrom ip+   tuplecheck (ipl, ipr) = (check ipl, check ipr)+   turning char ip+    | char == '<' = case dir ip of+       E -> (ip{dir = NE}, ip{dir = SE})+       SW -> (ip{dir = SE}, ip{dir = W})+       NW -> (ip{dir = W}, ip{dir = NE})+       _ -> (crashfrom ip, crashfrom ip)+    | char == '>' = case dir ip of+       W -> (ip{dir = SW}, ip{dir = NW})+       SE -> (ip{dir = E}, ip{dir = SW})+       NE -> (ip{dir = NW}, ip{dir = E})+       _ -> (crashfrom ip, crashfrom ip)+    | char == '^' = case dir ip of+       S -> (ip{dir = SE}, ip{dir = SW})+       NE -> (ip{dir = N}, ip{dir = SE})+       NW -> (ip{dir = SW}, ip{dir = N})+       _ -> (crashfrom ip, crashfrom ip)+    | char == 'v' = case dir ip of+       N -> (ip{dir = NW}, ip{dir = NE})+       SE -> (ip{dir = NE}, ip{dir = S})+       SW -> (ip{dir = S}, ip{dir = NW})+       _ -> (crashfrom ip, crashfrom ip)+    | otherwise = (ip, ip)++ -- returns insturction pointers turned for (Lambda, Reflected)+ lambdadirs :: IP -> (IP, IP)+ lambdadirs ip = addpath (ip, turnaround ip)++ -- moves both pointers one step+ tuplemove :: (IP, IP) -> (IP, IP)+ tuplemove (ipl, ipr) = (move ipl Forward, move ipr Forward)++ nodecount :: IP -> Int+ nodecount ip = Map.size (known ip)++ nodeadd :: IP -> Int -> IP+ nodeadd ip newnode = ip{count = 0, known = Map.insert (posx ip, posy ip, dir ip) newnode (known ip)}++ -- saves path information in instruction pointers+ addpath :: (IP, IP) -> (IP, IP)+ addpath (ipl, ipr) = (ipl{path = InstructionPointer.Left}, ipr{path = InstructionPointer.Right})++ -- make a 180° turn on instruction pointer+ turnaround :: IP -> IP+ turnaround ip = ip{dir = absolute ip{dir = absolute ip{dir = absolute ip{dir = absolute ip InstructionPointer.Left} InstructionPointer.Left} InstructionPointer.Left} InstructionPointer.Left}++ -- |Get ID of the node that has been already visited using the current IP+ -- (direction and coordinates).+ visited :: IP -- ^Instruction pointer to use.+    -> Int -- ^ID of visited node or 0 if none.+ visited ip = Map.findWithDefault 0 (posx ip, posy ip, dir ip) (known ip)++ -- |Get the position of a specific heading.+ posdir :: IP -- ^Current instruction pointer.+    -> RelDirection -- ^Current relative direction.+    -> (Int, Int) -- ^New position that results from the given relative movement.+ posdir ip reldir = posabsdir ip (absolute ip reldir)++ -- |Get the position of an absolute direction.+ posabsdir :: IP -- ^Current instruction pointer.+    -> Direction -- ^Current absolute direction.+    -> (Int, Int) -- ^New position that results from the given absolute movement.+ posabsdir ip N = (posy ip - 1, posx ip)+ posabsdir ip NE = (posy ip - 1, posx ip + 1)+ posabsdir ip E = (posy ip, posx ip + 1)+ posabsdir ip SE = (posy ip + 1, posx ip + 1)+ posabsdir ip S = (posy ip + 1, posx ip)+ posabsdir ip SW = (posy ip + 1, posx ip - 1)+ posabsdir ip W = (posy ip, posx ip - 1)+ posabsdir ip NW = (posy ip - 1, posx ip - 1)++ -- |Convert a relative direction into a relative one.+ absolute :: IP -- ^Current instruction pointer.+    -> RelDirection -- ^Relative direction to convert.+    -> Direction -- ^Equivalent absolute direction.+ absolute x Forward = dir x+ absolute (IP {dir=N}) InstructionPointer.Left = NW+ absolute (IP {dir=N}) InstructionPointer.Right = NE+ absolute (IP {dir=NE}) InstructionPointer.Left = N+ absolute (IP {dir=NE}) InstructionPointer.Right = E+ absolute (IP {dir=E}) InstructionPointer.Left = NE+ absolute (IP {dir=E}) InstructionPointer.Right = SE+ absolute (IP {dir=SE}) InstructionPointer.Left = E+ absolute (IP {dir=SE}) InstructionPointer.Right = S+ absolute (IP {dir=S}) InstructionPointer.Left = SE+ absolute (IP {dir=S}) InstructionPointer.Right = SW+ absolute (IP {dir=SW}) InstructionPointer.Left = S+ absolute (IP {dir=SW}) InstructionPointer.Right = W+ absolute (IP {dir=W}) InstructionPointer.Left = SW+ absolute (IP {dir=W}) InstructionPointer.Right = NW+ absolute (IP {dir=NW}) InstructionPointer.Left = W+ absolute (IP {dir=NW}) InstructionPointer.Right = N++ -- what is the primary rail for the given direction?+ -- mainly used to check if junctions turn away correctly+ primary :: IP -> Char+ primary ip+  | dir ip `elem` [N, S] = '|'+  | dir ip `elem` [E, W] = '-'+  | dir ip `elem` [NE, SW] = '/'+  | dir ip `elem` [NW, SE] = '\\'++-- vim:ts=2 sw=2 et
src/RailCompiler/InterfaceDT.hs view
@@ -14,10 +14,12 @@ module InterfaceDT where    import qualified LLVM.General.AST as LAST+  import qualified Data.Map as Map    -- type definitions ---  type Grid2D  = [String]-+  type Grid2D  = Map.Map Int (Map.Map Int Char)+  -- Int gives the line on which the function starts+  type PositionedGrid = (Grid2D, Int)   -- |(NodeID (start: 1), Lexeme of Node, NodeID of following Node (0 if none))   type LexNode = (Int, Lexeme, Int)   -- |(FunctionID, Graph of Function as adjacency list)@@ -27,17 +29,17 @@   -- |* following Nodes or Pathes could have ID==0, in this case there is no Follower    -- |Junction Int <=> if false goto Int; if true <=> following node+	-- |Lambda Int <=> Int holds node of anonymous function   data Lexeme = NOP | Boom | EOF | Input | Output | Underflow | RType |     Constant String | Push String | Pop String | Call String | Add1 | Divide |     Multiply | Remainder | Subtract | Cut | Append | Size | Nil | Cons |-    Breakup | Greater | Equal | Start | Finish | Junction Int deriving (Eq, Show)+    Breakup | Greater | Equal | Start | Finish | Junction Int | Lambda Int deriving (Eq, Show)    -- interface datatypes --   data Input2PreProc     = IIP String   deriving (Eq, Show)-  data PreProc2Lexer     = IPL [Grid2D] deriving (Eq, Show)+  data PreProc2Lexer     = IPL [PositionedGrid] deriving (Eq, Show)   data Lexer2SynAna      = ILS [Graph]  deriving (Eq, Show)   data SynAna2SemAna     = ISS [AST]    deriving (Eq, Show)   data SemAna2InterCode  = ISI [AST]    deriving (Eq, Show)-  data InterCode2CodeOpt = IIC LAST.Module deriving (Eq, Show)-  data CodeOpt2Backend   = ICB LAST.Module deriving (Eq, Show)+  data InterCode2Backend = IIB LAST.Module deriving (Eq, Show)   data Backend2Output    = IBO (IO String)
src/RailCompiler/IntermediateCode.hs view
@@ -1,7 +1,8 @@ {- | Module      :  IntermediateCode.hs Description :  Intermediate code generation-Copyright   :  (c) AUTHORS+Maintainer  :  Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke,+               Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu License     :  MIT Stability   :  unstable @@ -16,26 +17,27 @@ module IntermediateCode(process) where  -- imports ---import InterfaceDT as IDT import ErrorHandling as EH+import InterfaceDT as IDT+import FunctionDeclarations+import TypeDefinitions +import Control.Applicative+import Control.Monad.State+import Data.Char+import Data.List+import Data.Map hiding (filter, map)+import Data.Word import LLVM.General.AST-import qualified LLVM.General.AST.Global as Global+import LLVM.General.AST.AddrSpace import LLVM.General.AST.CallingConvention import LLVM.General.AST.Constant as Constant-import LLVM.General.AST.Linkage-import LLVM.General.AST.AddrSpace-import LLVM.General.AST.Operand+import LLVM.General.AST.Float import LLVM.General.AST.Instruction as Instruction import LLVM.General.AST.IntegerPredicate-import LLVM.General.AST.Float-import Data.Char-import Data.Word-import Data.List-import Data.Map hiding (filter, map)--import Control.Monad.State-import Control.Applicative+import LLVM.General.AST.Linkage+import LLVM.General.AST.Operand+import qualified LLVM.General.AST.Global as Global  data CodegenState = CodegenState {   blocks :: [BasicBlock],@@ -59,7 +61,7 @@ execCodegen :: Map String (Int, Integer) -> Codegen a -> a execCodegen d m = evalState (runCodegen m) $ CodegenState [] 0 d --- generate module from list of definitions+-- |Generate module from list of definitions. generateModule :: [Definition] -> Module generateModule definitions = defaultModule {   moduleName = "rail-heaven",@@ -76,7 +78,7 @@   metadata' = [] } --- generate global byte array (constant string)+-- |Generate global byte array (from a constant string). createGlobalString :: Lexeme -> Global createGlobalString (Constant s) = globalVariableDefaults {   Global.type' = ArrayType {@@ -92,218 +94,65 @@     l = toInteger $ 1 + length s     trans c = Int { integerBits = 8, integerValue = toInteger $ ord c } --- create constant strings/byte arrays for module--- TODO maybe rename these subfunctions?+-- |Create constant strings/byte arrays for a module.+-- TODO: Maybe rename these subfunctions? generateConstants :: [AST] -> [Global] generateConstants = map createGlobalString . getAllCons +-- |Get all 'Constant's in a module. getAllCons :: [AST] -> [Lexeme] getAllCons = concatMap generateCons+  where+    generateCons :: AST -> [Lexeme]+    generateCons (name, paths) = concatMap generateC paths -generateCons :: AST -> [Lexeme]-generateCons (name, paths) = concatMap generateC paths+    generateC :: (Int, [Lexeme], Int) -> [Lexeme]+    generateC (pathID, lex, nextPath) = filter checkCons lex -generateC :: (Int, [Lexeme], Int) -> [Lexeme]-generateC (pathID, lex, nextPath) = filter checkCons lex-checkCons (Constant c) = True-checkCons _ = False+    checkCons :: Lexeme -> Bool+    checkCons (Constant c) = True+    checkCons _ = False  ----------------------------------------------------------------------------------- generate global variables for push and pop form and into variables+-- |Generate global variables for push and pop from and into variables. createGlobalVariable :: Lexeme -> Global createGlobalVariable (Pop v) = globalVariableDefaults {   Global.name = Name v,-  Global.type' = bytePointerTypeVar,-  Global.initializer = Just (Undef VoidType)+  Global.type' = ArrayType {+    nArrayElements = fromInteger l,+    elementType = IntegerType {typeBits = 8}+  },+  Global.initializer = Just Array {+    memberType = IntegerType {typeBits = 8},+    memberValues = map trans v ++ [Int { integerBits = 8, integerValue = 0 }]+  } }+  where+    l = toInteger $ 1 + length v+    trans c = Int { integerBits = 8, integerValue = toInteger $ ord c } +-- |Generate all global variable definitions for a module. generateVariables :: [AST] -> [Global] generateVariables = map createGlobalVariable . getAllVars--getAllVars :: [AST] -> [Lexeme]-getAllVars = concatMap generateVars--generateVars :: AST -> [Lexeme]-generateVars (name, paths) = nub $ concatMap generateV paths --delete duplicates--generateV :: (Int, [Lexeme], Int) -> [Lexeme]-generateV (pathID, lex, nextPath) = filter checkVars lex-checkVars (Pop v) = True-checkVars _ = False------------------------------------------------------------------------------------- pointer type for i8* used e.g. as "string" pointer-bytePointerType = PointerType {-  pointerReferent = IntegerType 8,-  pointerAddrSpace = AddrSpace 0-}---- pointer type for i8** used as variable pointer-bytePointerTypeVar = PointerType {-  pointerReferent = PointerType {-    pointerReferent = IntegerType 8,-    pointerAddrSpace = AddrSpace 0-  },-  pointerAddrSpace = AddrSpace 0-}---- |Function declaration for 'underflow_check'.-underflowCheck = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "underflow_check",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'print'.-print = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "print",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'crash'.-crash = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "crash",-  Global.returnType = VoidType,-  Global.parameters = ([ Parameter (IntegerType 1) (Name "is_custom_error") [] ], False)-}---- |Function declaration for 'finish'.-finish = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "finish",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'input'.-inputFunc = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "input",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'eof_check'.-eofCheck = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "eof_check",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'add'.-add = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "add",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'rem'.-rem1 = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "rem",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'sub'.-sub = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "sub",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'mul'.-mul = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "mult",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}---- |Function declaration for 'div'.-div1 = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "div",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}----- function declaration for push-push = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "push",-  Global.returnType = VoidType,-  Global.parameters = ([ Parameter bytePointerType (UnName 0) [] ], False)-}---- function declaration for pop-pop = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "pop",-  Global.returnType = bytePointerType,-  Global.parameters = ([], False)-}---- function declaration for peek-peek = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "peek",-  Global.returnType = bytePointerType,-  Global.parameters = ([], False)-}----- function declaration for streq-streq = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "streq",-  Global.returnType = bytePointerType,-  Global.parameters = ([], False)-}---- function declaration for strlen-strlen = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "strlen",-  Global.returnType = bytePointerType,-  Global.parameters = ([], False)-}---- function declaration for strapp-strapp = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "strapp",-  Global.returnType = bytePointerType,-  Global.parameters = ([], False)-}+  where+    getAllVars :: [AST] -> [Lexeme]+    getAllVars = concatMap generateVars --- function declaration for pop_int-popInt = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "pop_int",-  Global.returnType = IntegerType 64,-  Global.parameters = ([], False)-}+    generateVars :: AST -> [Lexeme]+    generateVars (name, paths) = nub $ concatMap generateV paths --delete duplicates --- function declaration for equal-equal = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "equal",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}--- function declaration for greater-greater = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "greater",-  Global.returnType = VoidType,-  Global.parameters = ([], False)-}+    generateV :: (Int, [Lexeme], Int) -> [Lexeme]+    generateV (pathID, lex, nextPath) = filter checkVars lex --- function declaration for pop_into-popInto = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "pop_into",-  Global.returnType = VoidType,-  Global.parameters = ([ Parameter bytePointerTypeVar (UnName 0) [] ], False)-}+    checkVars :: Lexeme -> Bool+    checkVars (Pop v) = True+    checkVars _ = False --- function declaration for push_from-pushFrom = GlobalDefinition $ Global.functionDefaults {-  Global.name = Name "push_from",-  Global.returnType = VoidType,-  Global.parameters = ([ Parameter bytePointerTypeVar (UnName 0) [] ], False)-}+--------------------------------------------------------------------------------  -- |Generate an instruction for the 'u'nderflow check command.-generateInstruction Underflow =+generateInstruction :: (Lexeme, String) -> Codegen [Named Instruction]+generateInstruction (Underflow, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -314,14 +163,15 @@     metadata = []   }] -generateInstruction (Junction label) = do+-- |Generate instructions for junctions.+generateInstruction (Junction label, funcName) = do   index <- fresh   index2 <- fresh   return [ UnName index := LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,     returnAttributes = [],-    function = Right $ ConstantOperand $ GlobalReference $ Name "pop_int",+    function = Right $ ConstantOperand $ GlobalReference $ Name "pop_bool",     arguments = [],     functionAttributes = [],     metadata = []@@ -332,62 +182,51 @@     metadata = []   }] ---- generate instruction for pop into a variable-generateInstruction (Pop name) = do+-- |Generate instruction for pop into a variable+generateInstruction (Pop name, funcName) = do   index <- fresh-  index2 <- fresh-  index3 <- fresh-  return [ UnName index := Instruction.Alloca { -     allocatedType = bytePointerType,-     numElements = Nothing, --Just (LocalReference (Name name)),-     alignment = 4,-     metadata = []-  },    -    UnName index2 := LLVM.General.AST.Call {+  return [ UnName index := LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,     returnAttributes = [],     function = Right $ ConstantOperand $ GlobalReference $ Name "pop_into",-    arguments = [(LocalReference $ UnName index, [])],+    arguments = [ (LocalReference $ Name "table", []),+    (ConstantOperand Constant.GetElementPtr {+      Constant.inBounds = True,+      Constant.address = Constant.GlobalReference (Name name),+      Constant.indices = [+       Int { integerBits = 8, integerValue = 0 },+       Int { integerBits = 8, integerValue = 0 }+      ]}, [])],     functionAttributes = [],     metadata = []-  },-    UnName index3 := Instruction.Store {-    volatile = False,-    Instruction.address = ConstantOperand $ GlobalReference $ Name name,-    value = LocalReference (UnName index),-    maybeAtomicity = Nothing,-    alignment = 4,-    metadata = []-}]+  }] --- generate instruction for push from a variable-generateInstruction (Push name) = do+-- |Generate instruction for push from a variable+generateInstruction (Push name, funcName) = do   index <- fresh-  index2 <- fresh-  return [ UnName index := Instruction.Load { -     volatile = False,-     Instruction.address = ConstantOperand $ GlobalReference $ Name name,-     maybeAtomicity = Nothing,-     alignment = 4,-     metadata = []-  },    -    UnName index2 := LLVM.General.AST.Call {+  return [ UnName index := LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,     returnAttributes = [],     function = Right $ ConstantOperand $ GlobalReference $ Name "push_from",-    arguments = [(LocalReference $ UnName index, [])],+    arguments = [(LocalReference $ Name "table", []),+      (ConstantOperand Constant.GetElementPtr {+      Constant.inBounds = True,+      Constant.address = Constant.GlobalReference (Name name),+      Constant.indices = [+       Int { integerBits = 8, integerValue = 0 },+       Int { integerBits = 8, integerValue = 0 }+      ]}, [])],     functionAttributes = [],     metadata = []   }]  --- generate instruction for push of a constant+-- |Generate instruction for push of a constant. -- access to our push function definied in stack.ll?? -- http://llvm.org/docs/LangRef.html#call-instruction-generateInstruction (Constant value) = do+generateInstruction (Constant value, funcName) = do   index <- fresh   dict <- gets localDict   return [UnName index := LLVM.General.AST.Call {@@ -402,7 +241,7 @@     -- 'signext', and 'inreg' attributes are valid here     returnAttributes = [],     -- actual function to call-    function = Right $ ConstantOperand $ GlobalReference $ Name "push",+    function = Right $ ConstantOperand $ GlobalReference $ Name "push_string_cpy",     -- argument list whose types match the function signature argument types     -- and parameter attributes. All arguments must be of first class type. If     -- the function signature indicates the function accepts a variable number of@@ -433,7 +272,7 @@ -- a list of Instructions that we can insert in the BasicBlock  -- |Generate instruction for printing strings to stdout.-generateInstruction Output =+generateInstruction (Output, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -445,7 +284,7 @@   }]  -- |Generate instruction for the Boom lexeme (crashes program).-generateInstruction Boom =+generateInstruction (Boom, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -457,7 +296,7 @@   }]  -- |Generate instruction for the Input lexeme.-generateInstruction Input =+generateInstruction (Input, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -469,7 +308,7 @@   }]  -- |Generate instruction for the EOF lexeme.-generateInstruction EOF =+generateInstruction (EOF, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -481,7 +320,7 @@   }]  -- |Generate instruction for the add instruction.-generateInstruction Add1 =+generateInstruction (Add1, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -493,7 +332,7 @@   }]  -- |Generate instruction for the remainder instruction.-generateInstruction Remainder =+generateInstruction (Remainder, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -504,9 +343,20 @@     metadata = []   }] +-- |Generate instruction for the type instruction.+generateInstruction (RType, funcName) =+  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "type",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }]  -- |Generate instruction for the sub instruction.-generateInstruction Subtract =+generateInstruction (Subtract, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -518,7 +368,7 @@   }]  -- |Generate instruction for the mul instruction.-generateInstruction Multiply =+generateInstruction (Multiply, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -530,7 +380,7 @@   }]  -- |Generate instruction for the div instruction.-generateInstruction Divide =+generateInstruction (Divide, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -541,9 +391,8 @@     metadata = []   }] - -- |Generate instruction for the strlen instruction.-generateInstruction Size =+generateInstruction (Size, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -555,7 +404,7 @@   }]  -- |Generate instruction for the strapp instruction.-generateInstruction Append =+generateInstruction (Append, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -566,8 +415,20 @@     metadata = []   }] +-- |Generate instruction for the strcut instruction.+generateInstruction (Cut, funcName) =+  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "strcut",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }]+ -- |Generate instruction for the equal instruction.-generateInstruction Equal =+generateInstruction (Equal, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -578,9 +439,8 @@     metadata = []   }] - -- |Generate instruction for the greater instruction.-generateInstruction Greater =+generateInstruction (Greater, funcName) =   return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,@@ -591,13 +451,87 @@     metadata = []   }] --- do nothing?---generateInstruction Start =---  undefined+-- |Generate instruction for start instruction+generateInstruction (Start, funcName) = do+  index <- fresh+  index2 <- fresh+  return [ UnName index := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "start",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }]   +-- |Generate instructions for lambda push+generateInstruction (Lambda label, funcName) = do+  index <- fresh+  index2 <- fresh+  index3 <- fresh+  index4 <- fresh+  index5 <- fresh+  index6 <- fresh+  return [ UnName index := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "malloc",+    arguments = [(ConstantOperand $ Int 64 24, [])],+    functionAttributes = [],+    metadata = []+  },+    UnName index2 := LLVM.General.AST.BitCast {+    Instruction.operand0 = LocalReference $ UnName index,+    Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0),+    metadata = []+  },+    UnName index3 := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "initialise",+    arguments = [(LocalReference $ UnName index2, [])],+    functionAttributes = [],+    metadata = []+  },+    UnName index4 := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "copy_symbol_table",+    arguments = [(LocalReference $ Name "table", []), (LocalReference $ UnName index2, [])],+    functionAttributes = [],+    metadata = []+  },+    UnName index5 := LLVM.General.AST.Alloca {+    allocatedType = PointerType functionReturnLambda (AddrSpace 0),+    numElements = Nothing,+    alignment = 8,+    metadata = []+  },+    Do LLVM.General.AST.Store {+    volatile = False,+    Instruction.address = LocalReference $ UnName index5,+    value = ConstantOperand $ GlobalReference $ Name (funcName ++ "!" ++ show label),+    maybeAtomicity = Nothing,+    alignment = 8,+    metadata = []+  },+    UnName index6 := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "push_lambda",+    arguments = [(LocalReference $ UnName index5, []), (LocalReference $ UnName index2, [])],+    functionAttributes = [],+    metadata = []+  }]+ -- |Generate instruction for finish instruction-generateInstruction Finish =-    return [Do LLVM.General.AST.Call {+generateInstruction (Finish, funcName) =+  return [Do LLVM.General.AST.Call {     isTailCall = False,     callingConvention = C,     returnAttributes = [],@@ -607,22 +541,116 @@     metadata = []   }] --- noop-generateInstruction _ = return [ Do $ Instruction.FAdd (ConstantOperand $ Float $ Single 1.0) (ConstantOperand $ Float $ Single 1.0) [] ] -isUsefulInstruction Start = False-isUsefulInstruction _ = True+-- |Generate instruction for function call+generateInstruction (IDT.Call "", funcName) = do+  index <- fresh+  index2 <- fresh+  index6 <- fresh+  return [ UnName index := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "pop_lambda",+    arguments = [],+    functionAttributes = [],+    metadata = []+  },+    UnName index2 := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "get_lambda_pointer",+    arguments = [(LocalReference $ UnName index, [])],+    functionAttributes = [],+    metadata = []+  },+    UnName index6 := LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "get_lambda_table",+    arguments = [(LocalReference $ UnName index, [])],+    functionAttributes = [],+    metadata = []+  },+    Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ LocalReference $ UnName index2,+    arguments = [(LocalReference $ UnName index6, [])],+    functionAttributes = [],+    metadata = []+  }]+generateInstruction (IDT.Call functionName, funcName) = +  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name functionName,+    arguments = [],+    functionAttributes = [],+    metadata = []+  }] --- removes Lexemes without meaning to us-filterInstrs = filter isUsefulInstruction+-- |Generate instruction for pushing nil.+generateInstruction (Nil, funcName) =+  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_push_nil",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }] +-- |Generate instruction for list cons.+generateInstruction (Cons, funcName) =+  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_cons",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }] -generateBasicBlock :: (Int, [Lexeme], Int) -> Codegen BasicBlock-generateBasicBlock (label, instructions, 0) = do-  tmp <- mapM generateInstruction $ filterInstrs instructions+-- |Generate instruction for list breakup.+generateInstruction (Breakup, funcName) =+  return [Do LLVM.General.AST.Call {+    isTailCall = False,+    callingConvention = C,+    returnAttributes = [],+    function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_breakup",+    arguments = [],+    functionAttributes = [],+    metadata = []+  }]+++-- |Fallback for unhandled lexemes (generates no-op).+generateInstruction _ = return [ Do $ Instruction.FAdd (ConstantOperand $ Float $ Single 1.0) (ConstantOperand $ Float $ Single 1.0) [] ]++-- |Appends the function name to the lexemes/instructions.+--+-- The function name is only relevant for the Lambda instruction, because we use+-- "functionName"!"jumpLable" as name for the Lambda functions.+appendName :: [a] -> String -> [(a, String)]+appendName [] name = []+appendName (x:[]) name = [(x, name)]+appendName (x:xs) name = (x, name):rest+  where rest = appendName xs name++-- |Generate the instructions making up one basic block.+generateBasicBlock :: ((Int, [Lexeme], Int), String) -> Codegen BasicBlock+generateBasicBlock ((label, instructions, 0), name) = do+  tmp <- mapM generateInstruction (appendName instructions name)   return $ BasicBlock (Name $ "l_" ++ show label) (concat tmp) $ terminator 0-generateBasicBlock (label, instructions, jumpLabel) = do-  tmp <- mapM generateInstruction $ filterInstrs instructions+generateBasicBlock ((label, instructions, jumpLabel), name) = do+  tmp <- mapM generateInstruction (appendName instructions name)   i <- gets count   case filter isJunction instructions of     [Junction junctionLabel] -> return $ BasicBlock (Name $ "l_" ++ show label) (concat tmp) $ condbranch junctionLabel i@@ -641,30 +669,116 @@       metadata' = []     } --generateBasicBlocks :: [(Int, [Lexeme], Int)] -> Codegen [BasicBlock]-generateBasicBlocks = mapM generateBasicBlock+-- |Generate all basic blocks for a function.+generateBasicBlocks :: [(Int, [Lexeme], Int)] -> String -> Codegen [BasicBlock]+generateBasicBlocks lexemes name = mapM generateBasicBlock (appendName lexemes name) --- generate function definition from AST+-- |Generate a function definition from an AST.+-- +-- At the beginning of each function, we create a block with lable "entry".+-- In this block we create the symbol table and jump then to "l_1", the first +-- regular block in each function.+-- The first pattern-matching is for lambda functions generateFunction :: AST -> GlobalCodegen Definition generateFunction (name, lexemes) = do   dict <- gets dict-  return $ GlobalDefinition $ Global.functionDefaults {-    Global.name = Name name,-    Global.returnType = IntegerType 32,-    Global.basicBlocks = execCodegen dict $ generateBasicBlocks lexemes-  }+  return $ GlobalDefinition+    (if "!" `isInfixOf` name then+    Global.functionDefaults {+        Global.name = Name name,+        Global.returnType = IntegerType 32,+        Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name  +          "struct.table") (AddrSpace 0)) (Name "t") [] ], False ),+        Global.basicBlocks = concat ( +        return ( BasicBlock (Name "entry")  [ +        Name "table_alloc" := LLVM.General.AST.Call {+        isTailCall = False,+        callingConvention = C,+        returnAttributes = [],+        function = Right $ ConstantOperand $ GlobalReference $ Name "malloc",+        arguments = [(ConstantOperand $ Int 64 24, [])],+        functionAttributes = [],+        metadata = []+      },+        Name "table" := LLVM.General.AST.BitCast {+        Instruction.operand0 = LocalReference $ Name "table_alloc",+        Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0),+        metadata = []+      },+        Name "" := LLVM.General.AST.Call {+        isTailCall = False,+        callingConvention = C,+        returnAttributes = [],+        function = Right $ ConstantOperand $ GlobalReference $ Name "initialise",+        arguments = [(LocalReference $ Name "table", [])],+        functionAttributes = [],+        metadata = []+      },+      Name "" := LLVM.General.AST.Call {+        isTailCall = False,+        callingConvention = C,+        returnAttributes = [],+        function = Right $ ConstantOperand $ GlobalReference $ Name "copy_symbol_table",+        arguments = [(LocalReference $ Name "t", []), (LocalReference $ Name "table", [])],+        functionAttributes = [],+        metadata = []+      }]+        ( Do Br {+        dest = Name "l_1", +        metadata' = []} ))+       : [execCodegen dict $ generateBasicBlocks lexemes name])+      }+    else +    Global.functionDefaults {+        Global.name = Name name,+        Global.returnType = IntegerType 32,+        Global.basicBlocks = concat ( +        return ( BasicBlock (Name "entry")  [ +        Name "table_alloc" := LLVM.General.AST.Call {+        isTailCall = False,+        callingConvention = C,+        returnAttributes = [],+        function = Right $ ConstantOperand $ GlobalReference $ Name "malloc",+        arguments = [(ConstantOperand $ Int 64 24, [])],+        functionAttributes = [],+        metadata = []+      },+        Name "table" := LLVM.General.AST.BitCast {+        Instruction.operand0 = LocalReference $ Name "table_alloc",+        Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0),+        metadata = []+      },+        Name "" := LLVM.General.AST.Call {+        isTailCall = False,+        callingConvention = C,+        returnAttributes = [],+        function = Right $ ConstantOperand $ GlobalReference $ Name "initialise",+        arguments = [(LocalReference $ Name "table", [])],+        functionAttributes = [],+        metadata = []+      }]   +        ( Do Br {+        dest = Name "l_1", +        metadata' = []} ))+       : [execCodegen dict $ generateBasicBlocks lexemes name])+      }) ++-- |Create a new local variable (?). fresh :: Codegen Word fresh = do   i <- gets count   modify $ \s -> s { count = 1 + i }   return $ i + 1 --- generate list of LLVM Definitions from list of ASTs+-- |Generate list of LLVM Definitions from list of ASTs generateFunctions :: [AST] -> GlobalCodegen [Definition] generateFunctions = mapM generateFunction +-- |Generate a global definition for a constant.+--+-- This is an unnamed, global constant, i. e. it has a numeric name+-- like '@0'. generateGlobalDefinition :: Integer -> Global -> Definition generateGlobalDefinition index def = GlobalDefinition def {   Global.name = UnName $ fromInteger index,@@ -673,21 +787,66 @@   Global.hasUnnamedAddr = True } --- TODO find a more elegant way to solve this-generateGlobalDefinitionVar ::  Integer -> Global -> Definition+-- |Generate a global definition for a variable name.+--+-- Such definitions are used to pass variable names to+-- LLVM backend functions like 'pop_into()'.+generateGlobalDefinitionVar :: Integer -> Global -> Definition generateGlobalDefinitionVar i def = GlobalDefinition def {-  Global.initializer = Just (Undef VoidType)+  Global.isConstant = True,+  Global.linkage = Internal,+  Global.hasUnnamedAddr = True } --- entry point into module ---process :: IDT.SemAna2InterCode -> IDT.InterCode2CodeOpt-process (IDT.ISI input) = IDT.IIC $ generateModule $ constants ++ variables ++-    [ underflowCheck, IntermediateCode.print, crash, finish, inputFunc,-      eofCheck, push, pop, peek, add, sub, rem1, mul, div1, streq, strlen, strapp,-      popInt, equal, greater, popInto, pushFrom ] ++ generateFunctionsFoo input+-- |Entry point into module.+process :: IDT.SemAna2InterCode -> IDT.InterCode2Backend+process (IDT.ISI input) = IDT.IIB $ generateModule $ constants ++ variables ++ +    [+      stackElementTypeDef,+      structTable,+      lambdaElement,+      underflowCheck,+      FunctionDeclarations.print,+      crash,+      start,+      finish,+      inputFunc,+      eofCheck,+      pushStringCpy,+      pop,+      peek,+      add,+      sub,+      rem1,+      mul,+      div1,+      streq,+      strlen,+      strapp,+      strcut,+      popInt,+      equal,+      greater,+      popInto,+      pushFrom,+      popBool,+      initialiseSymbolTable,+      malloc,+      type1,+      copySymbolTable,+      pushLambda,+      getLambda,+      popLambda,+      getTable,+      listPushNil,+      listCons,+      listBreakup+    ] ++ codegen input   where     constants = zipWith generateGlobalDefinition [0..] $ generateConstants input     variables = zipWith generateGlobalDefinitionVar [0..] $ generateVariables input-    d = fromList $ zipWith foo [0..] $ getAllCons input-    foo index (Constant s) = (s, (length s, index)) --TODO rename foo to something meaningful e.g. createSymTable-    generateFunctionsFoo input = execGlobalCodegen d $ generateFunctions input+    constantPool = fromList $ zipWith createConstantPoolEntry [0..] $ getAllCons input+    createConstantPoolEntry index (Constant s) = (s, (length s, index))+    codegen input = execGlobalCodegen constantPool $ generateFunctions input++-- vim:ts=2 sw=2 et
src/RailCompiler/Lexer.hs view
@@ -26,88 +26,71 @@               -- * Utility functions               fromAST, toAST,               -- * Editor functions-              step, parse, IP(IP), posx, posy, start, crash, turnaround, junctionturns, lambdadirs , move , current, RelDirection(Forward)+              Direction (N, NE, E, SE, S, SW, W, NW),+              step, parse, IP(IP), dir, posx, posy, count, start, crash, turnaround, junctionturns, lambdadirs , move , current, RelDirection(Forward), funcname              )  where   -- imports --  import InterfaceDT as IDT  import ErrorHandling as EH+ import Data.Maybe  import Data.List- import Text.Printf-- -- |Modified 'IDT.LexNode' with an additional identifier for nodes- -- to check whether we have circles in the graph.- --- -- The identifier is the last element of the tuple and contains- -- the following sub-elements, in this order:- --- --     * When we visited this node, at which X position did we start to parse its lexeme?- --     * When we visited this node, at which Y position did we start to parse its lexeme?- --     * When we visited this node, from which direction did we come?- type PreLexNode = (Int, IDT.Lexeme, Int, (Int, Int, Direction))- -- |An absolute direction.- data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show)- -- |A relative direction.- data RelDirection = Left | Forward | Right deriving (Eq, Show)- -- |Instruction pointer consisting of position and an orientation.- data IP =-    IP {-      -- |Number of processed characters since start of current function.-      count :: Int,-      -- |Current X position.-      posx :: Int,-      -- |Current Y position.-      posy :: Int,-      -- |Current 'Direction'.-      dir :: Direction,-			-- |Determines if the instruction pointer is on a left or right path of a Junction-			path :: RelDirection-    }-  deriving (Show)-- instance Eq IP-  where-   (==) ipl ipr = posx ipl == posx ipr && posy ipl == posy ipr && dir ipl == dir ipr+ import AST+ import InstructionPointer+ import qualified Data.Map as Map    -- functions --   -- |Process preprocessor output into a list of function ASTs.  --+ --  -- Raises 'error's on invalid input; see 'ErrorHandling' for a list of error messages.  process :: IDT.PreProc2Lexer -- ^Preprocessor output (a list of lists of strings; i. e. a list of functions                               -- in their line representation).     -> IDT.Lexer2SynAna -- ^A list of ASTs, each describing a single function.- process (IDT.IPL input) = IDT.ILS $ concatMap processfn input+ process (IDT.IPL input) = IDT.ILS $ map (\(x, _) -> processfn x) input   -- |Process a single function.  processfn :: IDT.Grid2D -- ^The lines representing the function.-    -> [IDT.Graph] -- ^A graph of nodes representing the function.+    -> IDT.Graph -- ^A graph of nodes representing the function.                    -- There may be more functions because of lambdas.- processfn [x] = [(funcname x, [(1, Start, 0)])] -- oneliners are illegal; follower == 0 will-                                                 -- lead to a crash, which is what we want.- processfn code@(x:xs) = if head x /= '$' then [(funcname x, [(1, Start, 0)])] else [(funcname x, finalize (head nxs) [])]+ processfn code+   | Map.size code < 2 = emptyfunc -- oneliners are illegal; follower == 0 will+                               -- lead to a crash, which is what we want.+   | Map.size firstline == 0 || fromJust (Map.lookup 0 firstline) /= '$' = emptyfunc+   | otherwise = (func, finalize (head nxs))   where-    (nxs, _) = nodes code [[(1, Start, 0, (0, 0, SE))]] start+    emptyfunc = (func, [(1, Start, 0)])+    firstline = fromJust (Map.lookup 0 code)+    func = case funcname code of+      (Prelude.Left name) -> name+      (Prelude.Right err) -> error err+    (nxs, _) = nodes code [[(1, Start, 0)]] start   -- |Get the name of the given function.- --- -- TODO: Note that this will crash the entire program if there is- -- no function name.- funcname :: String -- ^A line containing the function declaration,-                    -- e. g. @$ \'main\'@.-    -> String -- ^The function name.- funcname line-  | null line || length (elemIndices '\'' line) < 2 = error EH.strFunctionNameMissing-  | otherwise = takeWhile (/='\'') $ tail $ dropWhile (/='\'') line+ funcname :: IDT.Grid2D -> Either String String+ funcname code+   | isNothing (Map.lookup 0 code) = Prelude.Right EH.strFunctionNameMissing+   | otherwise = helper (tostring 0 line)+  where+   line = fromJust (Map.lookup 0 code)+   tostring i line+     | isNothing (Map.lookup i line) = if i > Map.size line then "" else tostring (i+1) line+     | otherwise = fromJust (Map.lookup i line):tostring (i+1) line+   helper line+     | null line || length (elemIndices '\'' line) < 2 || null fn = Prelude.Right EH.strFunctionNameMissing+     | not $ null $ fn `intersect` "'{}()!" = Prelude.Right EH.strInvalidFuncName+     | otherwise = Prelude.Left fn+    where fn = takeWhile (/='\'') $ tail $ dropWhile (/='\'') line   -- |Get the nodes for the given function.  nodes :: IDT.Grid2D  -- ^Lines representing the function.-    -> [[PreLexNode]] -- ^Current graph representing the function.+    -> [[IDT.LexNode]] -- ^Current graph representing the function.                       -- Initialize with @[[(1, Start, 0, (0, 0, SE))]]@.     -> IP -- ^Current instruction pointer.           -- Initialize with @'start'@.-    -> ([[PreLexNode]], IP) -- ^Final graph for the function and the new instruction pointer.+    -> ([[IDT.LexNode]], IP) -- ^Final graph for the function and the new instruction pointer.  nodes code list ip   | current code tempip == ' ' = (list, tempip) -- If we are not finished yet, this will                                                 -- automatically lead to a@@ -115,13 +98,13 @@                                                 -- a leading node without a follower                                                 -- (follower == 0) because it is                                                 -- not modified here at all.-  | otherwise = if endless then (endlesslist, crash) else nodes code newlist newip-     where-      -- This checks if we have e. g. two reflectors that "bounce" the IP between them-      -- endlessly.-      endless = count ip > sum (map length code)-      endlesslist = (newnode, NOP, newnode, (-1, -1, SE)) `prepend` update list (path ip) newnode-      newnode = sum (map length list) + 1+  | endless = (endlesslist, crashfrom ip)+  | otherwise = nodes code newlist newip+   where+      -- This checks if we have e. g. two reflectors that "bounce" the IP between them endlessly.+      endless = count ip > 8 * Map.size (fromJust (Map.lookup 0 code)) * Map.size (fromJust (Map.lookup 0 code))+      endlesslist = (newnode, NOP, newnode) `prepend` update list (path ip) newnode+      newnode = nodecount ip + 1       prepend newx (x:xs) = (newx:x):xs       tempip = step code ip       (newlist, newip) = handle code list tempip@@ -129,65 +112,55 @@  -- |Helper function for 'nodes': Handle the creation of the next 'PreLexNode'  -- for the current function.  handle :: IDT.Grid2D -- ^Line representation of input function.-    -> [[PreLexNode]] -- ^Current list of nodes.+    -> [[IDT.LexNode]] -- ^Current list of nodes.     -> IP -- ^Current instruction pointer.-    -> ([[PreLexNode]], IP) -- ^New node list and new instruction pointer.+    -> ([[IDT.LexNode]], IP) -- ^New node list and new instruction pointer.  handle code list ip = helper code list newip lexeme   where    (lexeme, newip) = parse code ip    helper _ list ip Nothing = (list, ip)    helper code list ip (Just lexeme)-     | knownat > 0 = (update list (path ip) knownat, crash)-     | lexeme == Finish = (newlist, crash)-     | isjunction lexeme = (merge final, crash)-     | otherwise = (newlist, ip{count = 0})+     | knownat > 0 = (update list (path ip) knownat, crashfrom ip)+     | lexeme == Finish = (newlist, crashfrom newip)+     | isattributed lexeme = (merge final, crashfrom finip)+     | otherwise = (newlist, newip)     where-     knownat = visited list ip-     newnode = sum (map length list) + 1-     newlist = (newnode, lexeme, 0, (posx ip, posy ip, dir ip)) `prepend` update list (path ip) newnode+     knownat = visited ip+     newnode = nodecount ip + 1+     newlist = (newnode, lexeme, 0) `prepend` update list (path ip) newnode+     newip = nodeadd ip newnode      prepend newx (x:xs) = (newx:x):xs-     isjunction (Junction _) = True-     isjunction _ = False-     final = fst $ nodes code ([]:temp) trueip-     temp = fst $ nodes code ([]:newlist) falseip-     (falseip, trueip) = junctionturns code ip+     isattributed (Junction _) = True+     isattributed (Lambda _) = True+     isattributed _ = False+     (final, finip) = nodes code ([]:tempnodes) (ipmerge trueip tempip)+     (tempnodes, tempip) = nodes code ([]:newlist) (ipmerge falseip newip)+     (falseip, trueip) = if current code ip == '&' then lambdadirs ip else junctionturns code ip  -- -- |Shift a node by the given amount. May be positive or negative.- -- This is used by 'toGraph' and 'fromGraph' to shift all nodes by 1 or -1, respectively,- -- which is done because the portable text representation of the graph does not include- -- a leading "Start" node with ID 1 -- instead, the node with ID 1 is the first "real"- -- graph node. In other words, when exporting to the text representation, the "Start"- -- node is removed and all other nodes are "shifted" by -1 using this function. When- -- importing, a "Start" node is added and all nodes are shifted by 1.- offset :: Int -- ^Amount to shift node by.-    -> IDT.LexNode -- ^Node to operate on.-    -> IDT.LexNode -- ^Shifted node.- offset c (node, lexeme, 0) = (node + c, lexeme, 0)- offset c (node, lexeme, following) = (node + c, lexeme, following + c)-  -- |Change the following node of the first (i. e. "last", since the list is reversed)  -- node in the graph.- update :: [[PreLexNode]] -- ^The graph to operate on.+ update :: [[IDT.LexNode]] -- ^The graph to operate on.     -> RelDirection --  ^Turn taken on last Junctions     -> Int -- ^ID of new follower to set for the first node in the list.-    -> [[PreLexNode]] -- ^Resulting graph.+    -> [[IDT.LexNode]] -- ^Resulting graph.  update list@(x:xs) dir following-  | null x && startsjunction xs && dir == Lexer.Left = helpera list following-  | null x && not (null xs) && startsjunction (tail xs) && dir == Lexer.Right = x:head xs:helper (head (tail xs)) following:tail (tail xs)+  | null x && startsattributed xs && dir == InstructionPointer.Left = helpera list following+  | null x && not (null xs) && startsattributed (tail xs) && dir == InstructionPointer.Right = x:head xs:helper (head (tail xs)) following:tail (tail xs)   | null x = list   | otherwise = helper x following:xs    where-    helper ((node, lexeme, _, location):xs) following = (node, lexeme, following, location):xs-    helpera (x:(((node, _, following, location):xs):xss)) attribute = x:(((node, Junction attribute, following, location):xs):xss)-    startsjunction (((_, Junction _, _, _):_):_) = True-    startsjunction _ = False+    helper ((node, lexeme, _):xs) following = (node, lexeme, following):xs+    helpera (x:(((node, Junction _, following):xs):xss)) attribute = x:(((node, Junction attribute, following):xs):xss)+    helpera (x:(((node, Lambda _, following):xs):xss)) attribute = x:(((node, Lambda attribute, following):xs):xss)+    startsattributed (((_, Junction _, _):_):_) = True+    startsattributed (((_, Lambda _, _):_):_) = True+    startsattributed _ = False   -- merges splitted graphs (e.g. Junction)  -- x3 is the graph until the special node appeared  -- x2 is the graph that will result in the special attribute  -- x1 is the graph that will become the follower- merge :: [[PreLexNode]] -> [[PreLexNode]]+ merge :: [[IDT.LexNode]] -> [[IDT.LexNode]]  merge (x1:x2:x3:xs) = (x1 ++ x2 ++ x3):xs   -- |Move the instruction pointer a single step.@@ -196,464 +169,17 @@     -> IP -- ^New instruction pointer.  step code ip    | forward `elem` fval = move ip Forward-   | left `elem` lval && right `elem` rval = crash-   | left `elem` lval = move ip Lexer.Left-   | right `elem` rval = move ip Lexer.Right-   | otherwise = crash+   | left `elem` lval && right `elem` rval = crashfrom ip+   | left `elem` lval = move ip InstructionPointer.Left+   | right `elem` rval = move ip InstructionPointer.Right+   | otherwise = crashfrom ip   where    (left, forward, right) = adjacent code ip    (lval, fval, rval) = valids code ip - -- |Collect characters until a condition is met while moving in the current direction.- stepwhile :: IDT.Grid2D -- ^Line representation of current function.-    -> IP -- ^Current instruction pointer.-    -> (Char -> Bool) -- ^Function: Should return True if collection should stop.-                      -- Gets the current Char as an argument.-    -> (String, IP) -- ^Collected characters and the new instruction pointer.- stepwhile code ip fn-   | not (fn curchar) = ("", ip)-   | not (moveable code ip Forward) = error EH.strMissingClosingBracket-   | otherwise = (curchar:resstring, resip)-  where-   curchar = current code ip-   (resstring, resip) = stepwhile code (move ip Forward) fn-- -- |Checks if the instruction pointer can be moved without leaving the grid- moveable :: IDT.Grid2D -- ^Line representation of current function-    -> IP -- ^Current instruction pointer-    -> RelDirection -- ^Where to move to-    -> Bool -- ^Whether or not the move could be made- moveable code ip reldir-   | null code = False-   | newy < 0 || newy >= length code = False-   | dir ip `elem` [W, E] && (newx < 0 || newx >= length line) = False-   | otherwise = True-  where-   (newy, newx) = posdir ip reldir-   line = code!!newy-- -- |Read a string constant and handle escape sequences like \n.- -- Raises an error on invalid escape sequences and badly formatted constants.- readconstant :: IDT.Grid2D -- ^Current function in line representation-    -> IP -- ^Current instruction pointer-    -> Char -- ^Opening string delimiter, e. g. '['-    -> Char -- ^Closing string delimiter, e. g. ']'-    -> (String, IP) -- ^The processed constant and the new instruction pointer- readconstant code ip startchar endchar-    | curchar == startchar  = error EH.strNestedOpenBracket-    | curchar == endchar    = ("", ip)-    | not (moveable code ip Forward) = error EH.strMissingClosingBracket-    | otherwise             = (newchar:resstring, resip)-  where-    curchar                 = current code ip-    (newchar, newip)        = processescape-    (resstring, resip)      = readconstant code newip startchar endchar--    -- This does the actual work and converts the escape sequence-    -- (if there is no escape sequence at the current position, do-    -- nothing and pass the current Char through).-    processescape :: (Char, IP)-    processescape-        | curchar /= '\\'   = (curchar, move ip Forward)-        | esctrail /= '\\'  = error EH.strNonSymmetricEscape-        | otherwise         = case escsym of-            '\\' -> ('\\', escip)-            '['  -> ('[', escip)-            ']'  -> (']', escip)-            'n'  -> ('\n', escip)-            't'  -> ('\t', escip)-            _    -> error $ printf EH.strUnhandledEscape escsym-      where-        [escsym, esctrail]  = lookahead code ip 2-        -- Points to the character after the trailing backslash-        escip               = skip code ip 3-- -- |Lookahead n characters in the current direction.- lookahead :: IDT.Grid2D -- ^Line representation of current function-    -> IP -- ^Current instruction pointer-    -> Int -- ^How many characters of lookahead to produce?-    -> String -- ^n characters of lookahead- lookahead code ip 0 = []- lookahead code ip n = current code newip : lookahead code newip (n-1)-  where-    newip = move ip Forward-- -- |Skip n characters in the current direction and return the new IP.- skip :: IDT.Grid2D -- ^Line representation of current function-    -> IP -- ^Current instruction pointer-    -> Int  -- ^How many characters to skip? If 1, this is the same-            -- as doing "move ip Forward".-    -> IP -- ^New instruction pointer- skip code ip n = foldl (\x _ -> move x Forward) ip [1..n]-- -- |Move the instruction pointer in a relative direction.- move :: IP -- ^Current instruction pointer.-    -> RelDirection -- ^Relative direction to move in.-    -> IP -- ^New instruction pointer.- move ip reldir = ip{count = newcount, posx = newx, posy = newy, dir = absolute ip reldir}-  where-   (newy, newx) = posdir ip reldir-   newcount = count ip + 1-- -- |Get the 'Char' at the current position of the instruction pointer.- current :: IDT.Grid2D -- ^Line representation of the current function.-     -> IP -- ^Current instruction pointer.-     -> Char -- ^'Char' at the current IP position.- current code ip = charat code (posy ip, posx ip)-- -- |Get the 'Char' at the next position of the instruction pointer- next :: IDT.Grid2D -> IP -> Char- next code ip = current code $ move ip Forward-- -- |Get adjacent (left secondary, primary, right secondary)- -- symbols for the current IP position.- adjacent :: IDT.Grid2D -- ^Line representation of the current function.-     -> IP -- ^Current instruction pointer.-     -> (Char, Char, Char) -- ^Adjacent (left secondary, primary, right secondary) symbols- adjacent code ip-  | current code ip `elem` turnblocked = (' ', charat code (posdir ip Forward), ' ')-  | otherwise = (charat code (posdir ip Lexer.Left), charat code (posdir ip Forward), charat code (posdir ip Lexer.Right))-- -- returns instruction pointers turned for (False, True)- junctionturns :: IDT.Grid2D -> IP -> (IP, IP)- junctionturns code ip = tuplecheck $ tuplemove $ addpath $ turning (current code ip) ip-  where-   tuplecheck (ipl, ipr) = (if current code ipl == primary ipl then ipl else crash, if current code ipr == primary ipr then ipr else crash)-   tuplemove (ipl, ipr) = (move ipl Forward, move ipr Forward)-   addpath (ipl, ipr) = (ipl{path = Lexer.Left}, ipr{path = Lexer.Right})-   turning char ip-    | char == '<' = case dir ip of-       E -> (ip{dir = NE}, ip{dir = SE})-       SW -> (ip{dir = SE}, ip{dir = W})-       NW -> (ip{dir = W}, ip{dir = NE})-       _ -> (crash, crash)-    | char == '>' = case dir ip of-       W -> (ip{dir = SW}, ip{dir = NW})-       SE -> (ip{dir = E}, ip{dir = SW})-       NE -> (ip{dir = NW}, ip{dir = E})-       _ -> (crash, crash)-    | char == '^' = case dir ip of-       S -> (ip{dir = SE}, ip{dir = SW})-       NE -> (ip{dir = N}, ip{dir = SE})-       NW -> (ip{dir = SW}, ip{dir = N})-       _ -> (crash, crash)-    | char == 'v' = case dir ip of-       N -> (ip{dir = NW}, ip{dir = NE})-       SE -> (ip{dir = NE}, ip{dir = S})-       SW -> (ip{dir = S}, ip{dir = NW})-       _ -> (crash, crash)-    | otherwise = (ip, ip)-- -- returns insturction pointers turned for (Lambda, Reflected)- lambdadirs :: IP -> (IP, IP)- lambdadirs ip = (ip, turnaround ip)-- -- make a 180° turn on instruction pointer- turnaround :: IP -> IP- turnaround ip = ip{dir = absolute ip{dir = absolute ip{dir = absolute ip{dir = absolute ip Lexer.Left} Lexer.Left} Lexer.Left} Lexer.Left}-- -- |Returns 'Char' at given position, @\' \'@ if position is invalid.- charat :: IDT.Grid2D -- ^Line representation of current function.-    -> (Int, Int) -- ^Position as (x, y) coordinate.-    -> Char -- ^'Char' at given position.- charat code _ | null code = ' '- charat code (y, _) | y < 0 || y >= length code = ' '- charat code (y, x)-   | x < 0 || x >= length line = ' '-   | otherwise = line!!x-  where-   line = code!!y-- -- |Get the position of a specific heading.- posdir :: IP -- ^Current instruction pointer.-    -> RelDirection -- ^Current relative direction.-    -> (Int, Int) -- ^New position that results from the given relative movement.- posdir ip reldir = posabsdir ip (absolute ip reldir)-- -- |Get the position of an absolute direction.- posabsdir :: IP -- ^Current instruction pointer.-    -> Direction -- ^Current absolute direction.-    -> (Int, Int) -- ^New position that results from the given absolute movement.- posabsdir ip N = (posy ip - 1, posx ip)- posabsdir ip NE = (posy ip - 1, posx ip + 1)- posabsdir ip E = (posy ip, posx ip + 1)- posabsdir ip SE = (posy ip + 1, posx ip + 1)- posabsdir ip S = (posy ip + 1, posx ip)- posabsdir ip SW = (posy ip + 1, posx ip - 1)- posabsdir ip W = (posy ip, posx ip - 1)- posabsdir ip NW = (posy ip - 1, posx ip - 1)-- -- |Convert a relative direction into a relative one.- absolute :: IP -- ^Current instruction pointer.-    -> RelDirection -- ^Relative direction to convert.-    -> Direction -- ^Equivalent absolute direction.- absolute x Forward = dir x- absolute (IP {dir=N}) Lexer.Left = NW- absolute (IP {dir=N}) Lexer.Right = NE- absolute (IP {dir=NE}) Lexer.Left = N- absolute (IP {dir=NE}) Lexer.Right = E- absolute (IP {dir=E}) Lexer.Left = NE- absolute (IP {dir=E}) Lexer.Right = SE- absolute (IP {dir=SE}) Lexer.Left = E- absolute (IP {dir=SE}) Lexer.Right = S- absolute (IP {dir=S}) Lexer.Left = SE- absolute (IP {dir=S}) Lexer.Right = SW- absolute (IP {dir=SW}) Lexer.Left = S- absolute (IP {dir=SW}) Lexer.Right = W- absolute (IP {dir=W}) Lexer.Left = SW- absolute (IP {dir=W}) Lexer.Right = NW- absolute (IP {dir=NW}) Lexer.Left = W- absolute (IP {dir=NW}) Lexer.Right = N-- -- |Get the next lexeme at the current position.- parse :: IDT.Grid2D -- ^Line representation of current function.-    -> IP -- ^Current instruction pointer.-    -> (Maybe IDT.Lexeme, IP) -- ^Resulting lexeme (if any) and-                              -- the new instruction pointer.- parse code ip = junctioncheck $ case current code ip of-   'b' -> (Just Boom, ip)-   'e' -> (Just EOF, ip)-   'i' -> (Just Input, ip)-   'o' -> (Just Output, ip)-   'u' -> (Just Underflow, ip)-   '?' -> (Just RType, ip)-   'a' -> (Just Add1, ip)-   'd' -> (Just Divide, ip)-   'm' -> (Just Multiply, ip)-   'r' -> (Just Remainder, ip)-   's' -> (Just Subtract, ip)-   '0' -> (Just (Constant "0"), ip)-   '1' -> (Just (Constant "1"), ip)-   '2' -> (Just (Constant "2"), ip)-   '3' -> (Just (Constant "3"), ip)-   '4' -> (Just (Constant "4"), ip)-   '5' -> (Just (Constant "5"), ip)-   '6' -> (Just (Constant "6"), ip)-   '7' -> (Just (Constant "7"), ip)-   '8' -> (Just (Constant "8"), ip)-   '9' -> (Just (Constant "9"), ip)-   'c' -> (Just Cut, ip)-   'p' -> (Just Append, ip)-   'z' -> (Just Size, ip)-   'n' -> (Just Nil, ip)-   ':' -> (Just Cons, ip)-   '~' -> (Just Breakup, ip)-   'f' -> (Just (Constant "0"), ip)-   't' -> (Just (Constant "1"), ip)-   'g' -> (Just Greater, ip)-   'q' -> (Just Equal, ip)-   '$' -> (Just Start, ip)-   '#' -> (Just Finish, ip)-   '.' -> (Just NOP, ip)-   'v' -> (Just (Junction 0), ip)-   '^' -> (Just (Junction 0), ip)-   '>' -> (Just (Junction 0), ip)-   '<' -> (Just (Junction 0), ip)-   '[' -> let (string, newip) = readconstant code tempip '[' ']' in (Just (Constant string), newip)-   ']' -> let (string, newip) = readconstant code tempip ']' '[' in (Just (Constant string), newip)-   '{' -> let (string, newip) = stepwhile code tempip (/= '}') in (Just (Call string), newip)-   '}' -> let (string, newip) = stepwhile code tempip (/= '{') in (Just (Call string), newip)-   '(' -> let (string, newip) = stepwhile code tempip (/= ')') in (pushpop string, newip)-   ')' -> let (string, newip) = stepwhile code tempip (/= '(') in (pushpop string, newip)-   _ -> (Nothing, turn (current code ip) ip)-  where-   junctioncheck (Nothing, ip)-     | current code ip `elem` "+x*" && next code ip `elem` "v^<>" = (Nothing, crash)-     | forward == ' ' && (left == current code ip || right == current code ip) = (Nothing, crash)-     | forward == ' ' && (left `elem` "v^<>+x*" || right `elem` "v^<>+x*") = (Nothing, crash)-     | otherwise = (Nothing, ip)-    where-     (left, forward, right) = adjacent code ip-   junctioncheck (lexeme, ip)-    | next code ip `elem` "v^<>" = (lexeme, crash)-    | otherwise = (lexeme, ip)-   turn '@' ip = turnaround ip-   turn '|' ip-    | dir ip `elem` [NW, N, NE] = ip{dir = N}-    | dir ip `elem` [SW, S, SE] = ip{dir = S}-   turn '/' ip-    | dir ip `elem` [N, NE, E] = ip{dir = NE}-    | dir ip `elem` [S, SW, W] = ip{dir = SW}-   turn '-' ip-    | dir ip `elem` [NE, E, SE] = ip{dir = E}-    | dir ip `elem` [SW, S, NW] = ip{dir = W}-   turn '\\' ip-    | dir ip `elem` [W, NW, N] = ip{dir = NW}-    | dir ip `elem` [E, SE, S] = ip{dir = SE}-   turn _ ip = ip-   tempip = move ip Forward-   pushpop string-    | string == "" = Just (Push string)-    | head string == '!' && last string == '!' = Just (Pop (tail $ init string))-		| otherwise = Just (Push string)-- -- |Get ID of the node that has been already visited using the current IP- -- (direction and coordinates).- visited :: [[PreLexNode]] -- ^List of nodes to check.-    -> IP -- ^Instruction pointer to use.-    -> Int -- ^ID of visited node or 0 if none.- visited [] _ = 0- visited (x:xs) ip = let res = helper x ip in if res > 0 then res else visited xs ip-  where -   helper [] _ = 0-   helper ((id, _, _, (x, y, d)):xs) ip-    | x == posx ip && y == posy ip && d == dir ip = id-    | otherwise = helper xs ip-- -- |Convert a list of 'PreLexNode's into a list of 'IDT.LexNode's.- finalize :: [PreLexNode] -- ^'PreLexNode's to convert.-    -> [IDT.LexNode] -- ^Accumulator. Initialize with @[]@.-    -> [IDT.LexNode] -- ^Resulting list of 'IDT.PreLexNode's.- finalize [] result = result- finalize ((node, lexeme, following, _):xs) result = finalize xs ((node, lexeme, following):result)-- -- |Initial value for the instruction pointer at the start of a function.- start :: IP- start = IP 0 0 0 SE Forward-- -- |An instruction pointer representing a "crash" (fatal error).- crash :: IP- crash = IP 0 (-1) (-1) NW Forward-- -- what is the primary rail for the given direction?- -- mainly used to check if junctions turn away correctly- primary :: IP -> Char- primary ip-  | dir ip `elem` [N, S] = '|'-  | dir ip `elem` [E, W] = '-'-  | dir ip `elem` [NE, SW] = '/'-  | dir ip `elem` [NW, SE] = '\\'-- -- |Return valid chars for movement depending on the current direction.- valids :: IDT.Grid2D -- ^Line representation of current function.-    -> IP -- ^Current instruction pointer.-    -> (String, String, String) -- ^Tuple consisting of:-                                ---                                --     * Valid characters for movement to the (relative) left.-                                --     * Valid characters for movement in the (relative) forward direction.-                                --     * Valid characters for movement to the (relative) right.- valids code ip = tripleinvert (commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip Lexer.Left}, finvalid ip, commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip Lexer.Right})-  where-   tripleinvert (l, f, r) = (filter (`notElem` l) everything, filter (`notElem` f) everything, filter (`notElem` r) everything)-   finvalid ip = dirinvalid ip ++ crossinvalid ip -- illegal to move forward-   dirinvalid ip -- illegal without crosses-    | dir ip `elem` [E, W] = "|"-    | dir ip `elem` [NE, SW] = "\\"-    | dir ip `elem` [N, S] = "-"-    | dir ip `elem` [NW, SE] = "/"-    | otherwise = ""-   crossinvalid ip -- illegal crosses-    | dir ip `elem` [N, E, S, W] = "x"-    | otherwise = "+"-   cur = current code ip-   everything = "+\\/x|-" ++ always-   always = "^v<>*@{}[]()" ++ commandchars- - -- list of chars that are commands in rail- commandchars :: String- commandchars = "abcdefgimnopqrstuz:~0123456789?#"-- -- list of chars which do not allow any turning- turnblocked :: String- turnblocked = "$*+x" ++ commandchars-- -- |Convert a graph/AST into a portable text representation.- -- See also 'fromGraph'.- fromAST :: IDT.Lexer2SynAna -- ^Input graph/AST/forest.-    -> String -- ^Portable text representation of the AST:-              ---              -- Each function is represented by its own section. A section has a header-              -- and content; it continues either until the next section, a blank line or-              -- the end of the file, whichever comes first.-              ---              -- A section header consists of a single line containing the name of the function,-              -- enclosed in square brackets, e. g. @[function_name]@. There cannot be any whitespace-              -- before the opening bracket.-              ---              -- The section content consists of zero or more non-blank lines containing exactly-              -- three records delimited by a semicolon @;@. Each line describes a node and contains-              -- the following records, in this order:-              ---              --     * The node ID (numeric), e. g. @1@.-              --     * The Rail lexeme, e. g. @o@ or @[constant]@ etc. Note that track lexemes like-              --     @-@ or @+@ are not included in the graph. Multi-character lexemes like constants-              --     may include semicolons, so you need to parse them correctly! In other words, you need-              --     to take care of lines like @1;[some ; constant];2@.-              --     * Node ID of the follower node, e. g. @2@. May be @0@ if there is no next node.- fromAST (IDT.ILS graph) = unlines $ map fromGraph graph-- -- |Convert a portable text representation of a graph into a concrete graph representation.- -- See also 'toGraph'. See 'fromAST' for a specification of the portable text representation.- toAST :: String -- ^Portable text representation. See 'fromAST'.-    -> IDT.Lexer2SynAna -- ^Output graph.- toAST input = IDT.ILS (map toGraph $ splitfunctions input)-- -- |Convert an 'IDT.Graph' for a single function to a portable text representation.- -- See 'fromAST' for a specification of the representation.- --- -- TODO: Currently, this apparently crashes the program on invalid input. More sensible error handling?- --       At least a nice error message would be nice.- fromGraph :: IDT.Graph -- ^Input graph.-    -> String -- ^Text representation.- fromGraph (funcname, nodes) = unlines $ ("["++funcname++"]"):tail (map (fromLexNode . offset (-1)) nodes)-  where-   fromLexNode :: IDT.LexNode -> String-   fromLexNode (id, lexeme, follower) = show id ++ ";" ++ fromLexeme lexeme ++ ";" ++ show follower ++ optional lexeme-   fromLexeme :: IDT.Lexeme -> String-   fromLexeme Boom = "b"-   fromLexeme EOF = "e"-   fromLexeme Input = "i"-   fromLexeme Output = "o"-   fromLexeme Underflow = "u"-   fromLexeme RType = "?"-   fromLexeme (Constant string) = "["++string++"]"-   fromLexeme (Push string) = "("++string++")"-   fromLexeme (Pop string) = "(!"++string++"!)"-   fromLexeme (Call string) = "{"++string++"}"-   fromLexeme Add1 = "a"-   fromLexeme Divide = "d"-   fromLexeme Multiply = "m"-   fromLexeme Remainder = "r"-   fromLexeme Subtract = "s"-   fromLexeme Cut = "c"-   fromLexeme Append = "p"-   fromLexeme Size = "z"-   fromLexeme Nil = "n"-   fromLexeme Cons = ":"-   fromLexeme Breakup = "~"-   fromLexeme Greater = "g"-   fromLexeme Equal = "q"-   fromLexeme Start = "$"-   fromLexeme Finish = "#"-   fromLexeme (Junction _) = "v"-   fromLexeme NOP = "."-   optional (Junction follow) = ';' : show follow-   optional _ = ";0"-- -- |Split a portable text representation of multiple function graphs (a forest) into separate- -- text representations of each function graph.- splitfunctions :: String -- ^Portable text representation of the forest.-    -> [[String]] -- ^List of lists, each being a list of lines making up a separate function graph.- splitfunctions = groupBy (\_ y -> null y || head y /= '[') . filter (not . null) . lines-- -- |Convert a portable text representation of a single function into an 'IDT.Graph'.- -- Raises 'error's on invalid input (see 'ErrorHandling').- toGraph :: [String] -- ^List of lines making up the text representation of the function.-    -> IDT.Graph -- ^Graph describing the function.- toGraph lns = (init $ tail $ head lns, (1, Start, 2):map (offset 1) (nodes $ tail lns))-  where-   nodes [] = []-   nodes (ln:lns) = (read id, fixedlex, read follower):nodes lns-    where-     (id, other) = span (/=';') ln-     (lex, ip) = parse [other] $ IP 0 1 0 E Forward-     (follower, attribute) = span (/=';') (drop (2 + posx ip) other)-     fixedlex-      | isJunction lex = Junction (read $ tail attribute)-      | otherwise = fromJust lex-     fromJust Nothing = error $ printf EH.shrLineNoLexeme ln-     fromJust (Just x) = x-     isJunction (Just (Junction _)) = True-     isJunction _ = False+ -- |Brings it into right order+ finalize :: [IDT.LexNode] -- ^'LexNode's to convert.+    -> [IDT.LexNode] -- ^Resulting list of 'IDT.LexNode's.+ finalize = reverse  -- vim:ts=2 sw=2 et
− src/RailCompiler/Main.hs 
@@ -1,117 +0,0 @@-{- |-Module      : Main.hs-Description : .-Maintainer  : (c) Christopher Pockrandt, Nicolas Lehmann, Tobias Kranz-License     : MIT--Stability   : stable--Entrypoint of the rail2llvm-compiler. Contains main-function.--See also:---https://www.haskell.org/ghc/docs/7.8.2/html/libraries/base-4.7.0.0/System-Console-GetOpt.html---http://leiffrenzel.de/papers/commandline-options-in-haskell.html (Outdated!)---}-module Main( main ) where---- imports ---import System.Environment-import System.Exit-import System.Console.GetOpt-import Data.Maybe( fromMaybe )-import InterfaceDT                   as IDT-import qualified Preprocessor        as PreProc-import qualified Lexer-import qualified SyntacticalAnalysis as SynAna-import qualified SemanticalAnalysis  as SemAna-import qualified IntermediateCode    as InterCode-import qualified CodeOptimization    as CodeOpt-import qualified Backend---- defining the option settings for the main-function-data Options = Options  {-    optInput     :: IO String,-    optOutput    :: String -> IO (),-    optASTOutput :: String -> IO (),-    compile      :: Bool,-    impAST       :: Bool,-    expAST       :: Bool-  }---- default Options-defaultOptions :: Options-defaultOptions   = Options {-    optInput     = getContents,-    optOutput    = putStr,-    optASTOutput = putStr,-    compile      = False,-    impAST       = False,-    expAST       = False-    -  }---- usageInfo-options :: [OptDescr (Options -> IO Options)]-options = [-    --Option ['V'] ["version"] (NoArg  showVersion)      "show version number",-    Option "h" ["help"     ] (NoArg  showHelp         ) "display Help Text",-    Option "i" ["input"    ] (ReqArg setInput  "FILE" ) "input file (don't set to use stdin')",-    Option "o" ["output"   ] (ReqArg setOutput "FILE" ) "output file (don't set to use stdout')",-    Option "c" ["compile"  ] (NoArg  setCompile       ) "compile 'rail' to 'llvm'",-    Option [ ] ["exportAST"] (OptArg setExpAST "FILE" ) "export frontend AST (don't offer a File to use stdout) \n(dont set with --importAST)",-    Option [ ] ["importAST"] (NoArg setImpAST         ) "import frontend AST and compile to llvm\nautosets -c \n(set input via -i; (dont set with --exportAST)\n\nset -c with --exportAST and get both: the AST and the llvm code"    -  ]---- output for the help-function-showHelp _ = do-  putStrLn "rail2llvm--haskell-compiler (development version)"-  putStr "https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14\n\n"-  putStr $ usageInfo "Usage: main [OPTION...]" options  -  exitSuccess---- options-getter for optional output for exprotAST-getOut (Just arg) = writeFile arg-getOut Nothing = putStr---- options-setters-setInput  arg opt = return opt { optInput     = readFile arg }-setOutput arg opt = return opt { optOutput    = writeFile arg }-setExpAST arg opt = return opt { optASTOutput = getOut arg, expAST = True}-setImpAST     opt = return opt { impAST       = True, compile = True }-setCompile    opt = return opt { compile      = True }---- main-function ---main = do args <- getArgs-          let (actions,nonOpts,msgs) = getOpt RequireOrder options args-          -- intercept errors-          if msgs /= []-          then error $ concat msgs ++ usageInfo "Usage: main [OPTION...]" options-          -- unrecognized arguments error-          else if nonOpts /= [] -            then error $ "unrecognized arguments: " ++ unwords nonOpts ++ "\nUsage: For basic information, try the `--help' option."-            else do opts <- foldl (>>=) (return defaultOptions) actions-                    -- option aliases-                    let Options { optInput = input, optOutput = output,  optASTOutput = outputAST, compile = cmpl, impAST = imp, expAST = exp} = opts-                    inputWithoutIO <- input-                    -- importAST and exportAST can't be set together (error)-                    if imp && exp -                    then do error "No export of the imported AST (Usage: For basic information, try the `--help' option.)'"-                            exitSuccess-                    -- compile a file-                    else if cmpl -                         then do let transform (IBO x) = x-                                 -- compile an imported AST to a LLVM-file-                                 if imp-                                 then transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.toAST $ inputWithoutIO) >>= output-                                 -- compile a RAIL-file to an AST as an export-file-                                 else if exp-                                      then do outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO)-                                              transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output-                                      -- compile a RAIL-file to a LLVM-file-                                      else transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output-                         -- exportAST (without compiling it to llvm)-                         else if exp-                              then outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO)-                              -- missing argument error-                              else error "Error. Set atleast -c or --importAST or --exportAST."
src/RailCompiler/Preprocessor.hs view
@@ -18,29 +18,51 @@    -- imports --  import InterfaceDT as IDT- import ErrorHandling as EH + import ErrorHandling as EH  import Data.List+ import Control.Arrow+ import qualified Data.Map as Map    -- functions --  process :: IDT.Input2PreProc -> IDT.PreProc2Lexer  process (IDT.IIP input) = IDT.IPL output   where-   output = (groupFunctionsToGrid2Ds . removeLines . lines) input+   output = map (Control.Arrow.first convert . Control.Arrow.first maximize) groups+   groups = (groupFunctions . removeLines . lines) input + convert :: [String] -> Grid2D+ convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code)++ -- |Makes the first line as long as max(max(lines),#lines)+ -- this is useful for the lexer to determine an upper bound for empty endless loops+ maximize :: [String] -> [String]+ maximize [] = []+ maximize (x:xs) = stretchto (max maxlines maxcols) x:xs+  where+   stretchto count line = take count (line ++ repeat ' ')+   maxlines = maximum $ map length (x:xs)+   maxcols = length (x:xs)+  -- |Return False iff the first character is a dollar sign.  notStartingWithDollar :: String -> Bool  notStartingWithDollar x = null x || head x /= '$'    -- |Removes all leading strings from list until first string begins with a  -- dollar sign.- removeLines :: Grid2D -> Grid2D+ removeLines :: [String] -> ([String], Int)  removeLines grid-  | null result = error noStartSymbolFound-  | otherwise = result+  | null $ fst $ result grid 0 = error noStartSymbolFound+  | otherwise = result grid 0    where-   result = dropWhile notStartingWithDollar grid+    result grid n+     | null grid = (grid, n)+     | not $ notStartingWithDollar $ head grid = (grid, n)+     | otherwise = result (tail grid) (n + 1)   -- |Puts every rail function/program into its on grid such that the dollar  -- sign is the first character in the first line.- groupFunctionsToGrid2Ds :: Grid2D -> [Grid2D]- groupFunctionsToGrid2Ds = groupBy (\_ y -> notStartingWithDollar y)+ groupFunctions :: ([String], Int) -> [([String], Int)]+ groupFunctions ([], _) = []+ groupFunctions (grid, offset) = (head grid:func, offset):groupFunctions (other, offset + 1 + length func)+  where+   (func, other) = span notStartingWithDollar $ tail grid
src/RailCompiler/SemanticalAnalysis.hs view
@@ -16,19 +16,57 @@  -- imports --  import InterfaceDT as IDT  import ErrorHandling as EH+ import Data.List    -- functions --  process :: IDT.SynAna2SemAna -> IDT.SemAna2InterCode  process (IDT.ISS input)+  | null input = error EH.strEmptyProgram+  | duplicatefunctions input = error EH.strDuplicateFunctions   | nomain input = error EH.strMainMissing-  | otherwise = IDT.ISI (map check input)+  | not (all validfollowers input) = error EH.strUnknownNode+  | otherwise = IDT.ISI (concatMap splitlambda $ map check input) + -- splits lambdas into own functions+ splitlambda :: IDT.AST -> [IDT.AST]+ splitlambda func@(funcname, paths) = func : lambdafuncs 1+  where+   lambdafuncs offset+    | offset > maximum (fst (getids func)) = []+    | islambda offset = (funcname ++ "!" ++ show offset, (1, [NOP], offset):tail paths):lambdafuncs (offset + 1)+    | otherwise = lambdafuncs (offset + 1)+   islambda x = any (\(_, lex, _) -> Lambda x `elem` lex) paths++ -- checks if there are unknown followers+ validfollowers :: IDT.AST -> Bool+ validfollowers ast = null subset+  where+   (ids, followers) = getids ast+   subset = nub followers \\ ids++ -- gets a tuple of (ids, followers) to check if there are unknown followers+ getids :: IDT.AST -> ([Int], [Int])+ getids (_, nodes) = unzip (getnodeids nodes)+  where+   getnodeids [] = []+   getnodeids ((id, nodes, follow):xs) = (0, junctionattribute nodes):(id, follow):getnodeids xs+   junctionattribute nodes = case last nodes of+    (Junction attribute) -> attribute+    _ -> 0+  -- looking for a main function  nomain :: [IDT.AST] -> Bool- nomain [] = True- nomain ((name, _):xs)-  | name == "main" = False-	| otherwise = nomain xs+ nomain input = "main" `notElem` allfunctions input++ -- checking if there are two or more functions with the same name+ duplicatefunctions :: [IDT.AST] -> Bool+ duplicatefunctions input = length functions > length (nub functions)+  where functions = allfunctions input++ -- getting a list of every function+ allfunctions :: [IDT.AST] -> [String]+ allfunctions [] = []+ allfunctions ((name, _):xs) = name:allfunctions xs    -- this will return the exact same input if it's valid and will error otherwise  check :: IDT.AST -> IDT.AST@@ -37,13 +75,15 @@  -- this will return the exact same input if it's valid and will error otherwise  checknode :: (Int, [Lexeme], Int) -> (Int, [Lexeme], Int)  checknode (id, lexeme, following)-   | following == 0 && not (last lexeme `elem` [Finish, Boom] || isvalidjunction (last lexeme)) = error EH.strInvalidMovement+   | following == 0 && not (last lexeme `elem` [Finish, Boom] || isinvalidjunction (last lexeme)) = error EH.strInvalidMovement    | otherwise = (id, map checklexeme lexeme, following) 	where-   isvalidjunction (Junction x) = x /= 0-   isvalidjunction _ = False+   isinvalidjunction (Junction x) = x == 0+   isinvalidjunction _ = False   -- this will return the exact same input if it's valid and will error otherwise  checklexeme :: Lexeme -> Lexeme  checklexeme (Junction 0) = error EH.strInvalidMovement+ checklexeme (Push "") = error EH.strInvalidVarName+ checklexeme (Pop "") = error EH.strInvalidVarName  checklexeme lexeme = lexeme
src/RailCompiler/SyntacticalAnalysis.hs view
@@ -1,7 +1,7 @@ {- | Module      :  SyntacticalAnalysis.hs Description :  .-Copyright   :  (c) Kristin Knorr, Marcus Hoffmann+Maintainer  :  (c) Kristin Knorr, Marcus Hoffmann License     :  MIT  Stability   :  stable@@ -18,52 +18,60 @@  -- imports --  import InterfaceDT as IDT  import ErrorHandling as EH+ import Data.Maybe+ import qualified Data.Map as Map   -- functions --  process :: IDT.Lexer2SynAna -> IDT.SynAna2SemAna  process (IDT.ILS input) = IDT.ISS output   where-   output = map (\(x, y)->(x, pathes y (startNodes y))) input+   output = map (\(x, y)->(x, pathes (mapify y Map.empty) (startNodes y))) input  + mapify :: [(Int, Lexeme, Int)] -> Map.Map Int (Lexeme, Int) -> Map.Map Int (Lexeme, Int)+ mapify [] map = map+ mapify ((id, lexeme, follower):xs) map = mapify xs (Map.insert id (lexeme, follower) map)+  -- |generates all pathes of a graph- pathes :: [IDT.LexNode] -> [Int] -> [(Int, [Lexeme], Int)]- pathes xs ys = map (\x-> findPath x xs ys) ys+ pathes :: Map.Map Int (Lexeme, Int) -> [Int] -> [(Int, [Lexeme], Int)]+ pathes _ [] = []+ pathes xs ys+  | Map.size xs == 0 = []+  | otherwise = map (\x-> findPath x xs ys) ys    -- |generates one path depending on initial node- findPath :: Int -> [IDT.LexNode] -> [Int] -> (Int, [Lexeme], Int)+ findPath :: Int -> Map.Map Int (Lexeme, Int) -> [Int] -> (Int, [Lexeme], Int)  findPath x xs ys = genPath x (generate x xs)     where         genPath :: Int -> [(Lexeme, Int)] -> (Int, [Lexeme], Int)         genPath pathID leFoList = (pathID, map fst leFoList, (snd.last) leFoList)-        generate :: Int -> [IDT.LexNode] -> [(Lexeme, Int)]-        generate v = genElem . head . filter (\y -> fst' y == v)-        genElem :: IDT.LexNode -> [(Lexeme, Int)]-        genElem (nodeID, lex, fol)+        generate :: Int -> Map.Map Int (Lexeme, Int) -> [(Lexeme, Int)]+        generate v map = genElem $ fromJust $ Map.lookup v map+        genElem :: (Lexeme, Int) -> [(Lexeme, Int)]+        genElem (lex, fol)             |elem fol ys || fol==0 = [(lex, fol)]             |otherwise             = (lex, fol) : generate fol xs  + -- |fetch triple components+ fst' :: (a, b, c) -> a+ fst' (x, _, _) = x+   -- |generates a list of all nodes, which are needed to be initial nodes of path:  -- 1 as functionstart; conditional jmp; indegree > 1  startNodes :: [IDT.LexNode] -> [Int]+-- startNodes xs = error (show (Map.toList (nodeCount xs Map.empty)))+-- startNodes xs = error (show (fst' (head xs):(Map.keys $ Map.filter (/= 1) $ nodeCount xs Map.empty)))  startNodes [] = []- startNodes xs = 1:[x | x <- [2..(length xs)], isJunct0 x xs || (inDeg x xs > 1) || isJunct1 x xs]+ startNodes xs = fst' (head xs):filter (/=0) (Map.keys $ Map.filter (/= 1) $ nodeCount xs Map.empty)     where-        isJunct0 :: Int -> [IDT.LexNode] -> Bool-        isJunct0 x = any (\y -> Junction x == snd' y)-        isJunct1 :: Int -> [IDT.LexNode] -> Bool-        isJunct1 x = any (\y -> isJunct (snd' y) && x == trd' y)-        isJunct :: Lexeme -> Bool-        isJunct (Junction x) = True-        isJunct _ = False-        inDeg :: Int -> [IDT.LexNode] -> Int-        inDeg x = length . filter (\y-> trd' y==x)- - -- |fetch triple components- fst' :: (a, b, c) -> a- fst' (x, _, _) = x- - snd' :: (a, b, c) -> b- snd' (_, x, _) = x- - trd' :: (a, b, c) -> c- trd' (_, _, x) = x+        -- result type: [(ID, Count)]+        nodeCount :: [IDT.LexNode] -> Map.Map Int Int -> Map.Map Int Int+        nodeCount [] res = res+        -- we WANT junctions to be at the very end+        nodeCount ((_, Junction x, y):xs) res = nodeCount xs $ incCount (incCount res x 2) y 2+        nodeCount ((_, Lambda x, y):xs) res = nodeCount xs $ incCount (incCount res x 2) y 1+        nodeCount ((_, _, y):xs) res = nodeCount xs $ incCount res y 1+        -- update the count+        incCount :: Map.Map Int Int -> Int -> Int-> Map.Map Int Int+        incCount map id count+            | Map.member id map = Map.adjust (count +) id map+            | otherwise = Map.insert id count map
+ src/RailCompiler/TypeDefinitions.hs view
@@ -0,0 +1,66 @@+{- |+Module      :  TpyeDefinitions.hs+Description :  type definitions for intermediate code generation+Maintainer  :  Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke,+               Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu+License     :  MIT+Stability   :  unstable++All type definitions live here.++-}++module TypeDefinitions where++import LLVM.General.AST+import LLVM.General.AST.AddrSpace++-- |Opaque type definition for the stack_element struct, defined in stack.ll.+stackElementTypeDef :: Definition+stackElementTypeDef = TypeDefinition (Name "stack_element") Nothing++-- |Pointer type for 'i8*' used e.g. as "string" pointer+bytePointerType :: Type+bytePointerType = PointerType {+  pointerReferent = IntegerType 8,+  pointerAddrSpace = AddrSpace 0+}++-- |Pointer type for 'i8**' used as variable pointer+bytePointerTypeVar :: Type+bytePointerTypeVar = PointerType {+  pointerReferent = PointerType {+    pointerReferent = IntegerType 8,+    pointerAddrSpace = AddrSpace 0+  },+  pointerAddrSpace = AddrSpace 0+}++-- |Pointer type: %stack_element* (see stack.ll).+stackElementPointerType :: Type+stackElementPointerType = PointerType {+    pointerReferent = NamedTypeReference $ Name "stack_element",+    pointerAddrSpace = AddrSpace 0+}++-- |Struct declaration for the symbol table+structTable :: Definition+structTable = TypeDefinition (Name "struct.table")+      (Just $ StructureType False+                [ PointerType (IntegerType 8) (AddrSpace 0), +                  PointerType (NamedTypeReference $ Name "stack_element") (AddrSpace 0), +                  PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0)])++functionReturnLambda :: Type+functionReturnLambda = FunctionType {+      resultType = IntegerType 32,+      argumentTypes = [ PointerType (NamedTypeReference $ Name "struct.table")+         (AddrSpace 0)],+      isVarArg = False+}++lambdaElement :: Definition+lambdaElement = TypeDefinition (Name "lambda_element")+      (Just $ StructureType False+                [ PointerType (PointerType functionReturnLambda (AddrSpace 0)) (AddrSpace 0), +                  PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0)])
+ src/RailCompiler/cmp.ll view
@@ -0,0 +1,379 @@+; Module      : LLVM backend - comparison functions+; Description : Contains LLVM functions for integer/float comparison.+; Maintainers : Sascha Zinke, Tudor Soroceanu+; License     : MIT+;+; These comparison functions are used by our LLVM backend and operate directly+; on the stack -- see stack.ll.++@err_numeric = external global [56 x i8]+@err_type = external global [14 x i8]+@err_zero = external global [18 x i8]+@popped = external global [13 x i8]+@true = external global [2 x i8]+@false = external global [2 x i8]++%stack_element = type opaque+%struct.stack_elem = type { i32, %union.anon }+%union.anon = type { i8* }++declare i8* @stack_element_get_data(%stack_element* %element)+declare i8 @stack_element_get_type(%stack_element*)+declare void @stack_element_unref(%stack_element* %element)+declare i32 @get_stack_elem(i8*, %struct.stack_elem*)+declare %stack_element* @push_string_ptr(i8* %str)+declare %stack_element* @push_string_cpy(i8* %str)+declare %stack_element* @pop_struct()+declare signext i32 @printf(i8*, ...)+declare void @push_float(double)+declare void @underflow_assert()+declare i32 @strcmp(i8*, i8*)+declare void @push_int(i64)+declare i8* @pop_string()+declare void @crash(i1)+declare i1 @list_equal(%stack_element*, %stack_element*)++@main.number_a = private unnamed_addr constant [4 x i8] c"abc\00"+@main.number_b  = private unnamed_addr constant [4 x i8] c"adc\00"++define i32 @main_cmp() {+  ; push two numbers on the stack+  %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0   +  %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0   ++  call %stack_element* @push_string_cpy(i8* %number0)+  call %stack_element* @push_string_cpy(i8* %number1)++  call void @equal()+  %result = call i8* @pop_string()+  call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]*+              @popped, i32 0, i32 0), i8* %result)++  ret i32 0+}+++;##############################################################################+;                                 equal+;##############################################################################+++; Check if the topmost stack elements are equal.+;+; Pushes true onto the stack if the elements are equal and false+; otherwise.+;+; Crashes the program on errors (prints an appropriate error message).+define void @equal() {+  %struct_a = call %stack_element* @pop_struct()+  %struct_b = call %stack_element* @pop_struct()+  %are_equal = call i1 @do_equal(%stack_element* %struct_a, %stack_element* %struct_b)++  br i1 %are_equal, label %push_true, label %push_false++push_true:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [2 x i8]* @true, i64 0, i64 0))+  br label %done++push_false:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [2 x i8]* @false, i64 0, i64 0))+  br label %done++done:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  ret void+}++; Perform the actual equality check.+;+; Returns 1 if the stack elements are equal or 0 otherwise.+;+; Crashes the program on errors (prints an appropriate error message).+define i1 @do_equal(%stack_element* %struct_a, %stack_element* %struct_b) {+  ; return value of this function+  %func_result = alloca i1, align 4++  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8+ +  ; Get data and type of first element.+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)+  %stack_type_a = call i8 @stack_element_get_type(%stack_element* %struct_a)++  ; Get data and type of second element.+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)+  %stack_type_b = call i8 @stack_element_get_type(%stack_element* %struct_b)++  ; The spec says that two elements of different types are always unequal.+  %equal_stack_types = icmp eq i8 %stack_type_a, %stack_type_b+  br i1 %equal_stack_types, label %check_stack_type, label %exit_with_false++check_stack_type:+  ; Same stack element type, so it does not matter which of the two types+  ; we use in the switch statement.+  switch i8 %stack_type_a, label %exit_with_invalid_type+    [+      i8 0, label %get_stack_elem_a+      i8 1, label %compare_lists+    ]++get_stack_elem_a:+  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float+                                        i32 3, label %assume_b_string]++;##############################################################################+;                        list comparison+;##############################################################################++compare_lists:+  %lists_are_equal = call i1 @list_equal(%stack_element* %struct_a, %stack_element* %struct_b)+  br i1 %lists_are_equal, label %exit_with_true, label %exit_with_false++;##############################################################################+;                        integer comparison+;##############################################################################++assume_b_int:+  ; check whether it is 1 (aka INT).+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %cmp_int, label %exit_with_invalid_type+                                       +cmp_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32*+  %ival_a = load i32* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32*+  %ival_b = load i32* %ival_b_cast, align 4++  ; the actual comparison+  %equal_int = icmp eq i32 %ival_a, %ival_b +  br i1 %equal_int, label %exit_with_true, label %exit_with_false++;##############################################################################+;                        floating point comparison+;##############################################################################++assume_b_float:+  ; check whether it is 2 (aka FLOAT).+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type++cmp_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4++  %equal_float = fcmp oeq float %fval_a, %fval_b+  br i1 %equal_float, label %exit_with_true, label %exit_with_false++;##############################################################################+;                        string comparison+;##############################################################################++assume_b_string:+  ; check whether it is 3 (aka STRING).+  %is_string_b = icmp eq i32 %type_b, 3+  br i1 %is_string_b, label %cmp_str, label %exit_with_invalid_type++cmp_str:  +  %equal_string = call i32 @strcmp(i8* %number_a, i8* %number_b)+  %is_equal = icmp eq i32 %equal_string, 0+  br i1 %is_equal, label %exit_with_true, label %exit_with_false++++++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void @crash(i1 0)+  ret i1 1++exit_with_true:+  store i1 1, i1* %func_result+  br label %exit++exit_with_false:+  store i1 0, i1* %func_result+  br label %exit++exit:+  %result = load i1* %func_result+  ret i1 %result+}++;##############################################################################+;                                 greater+;##############################################################################++define i32 @greater(){+  ; return value of this function+  %func_result = alloca i32, align 4++  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8+ +  ; get top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get second top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]++ ;##############################################################################+;                        integer greater+;##############################################################################++assume_b_int:+  ; check whether it is 1 (aka INT).+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %cmp_int, label %exit_with_invalid_type+ +cmp_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32*+  %ival_a = load i32* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32*+  %ival_b = load i32* %ival_b_cast, align 4++  ; the actual comparison+  %greater_int = icmp sgt i32 %ival_a, %ival_b +  br i1 %greater_int, label %exit_with_true, label %exit_with_false++;##############################################################################+;                        floating point multiplication+;##############################################################################++assume_b_float:+  ; check whether it is 2 (aka FLOAT).+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type++cmp_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4++  ; prevent division by zero+  %greater_float = fcmp ogt float %fval_a, %fval_b+  br i1 %greater_float, label %exit_with_true, label %exit_with_false++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit_with_true: +  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [2 x i8]* @true, i64 0, i64 0))+  br label %exit_with_success++exit_with_false: +  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [2 x i8]* @false, i64 0, i64 0))+  br label %exit_with_success++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++; vim:ts=2 sw=2 et
+ src/RailCompiler/linked_stack.ll view
@@ -0,0 +1,630 @@+; Module      : LLVM backend - linked stack implementation/reference counting+; Description : Contains our linked stack implementation and its reference counting+;               routines.+; Maintainers : Tilman Blumenbach et al.+; License     : MIT+;+; These functions are used by our LLVM backend and most of them operate directly on+; the stack. Many also directly crash (in Rail terms: properly exit) the program.+++; Types++; A "real" stack element that is stored on the stack -- but only+; indirectly, see %stack_wrapper.+;+; The fields are:+;  * i8 dataType: Type of the data stored in dataPtr.+;    * 0 means string. dataPtr points to a null-terminated string.+;    * 1 means list. Note that there is no seperate type for empty lists,+;      those are represented with type == 1 and dataPtr == null.+;      For non-empty lists, dataPtr points to another stack_wrapper which+;      is the head of the (linked) list.+;    * 2 means lambda.+;  * void *dataPtr: Points to type-specific data. May be null.+;  * i32 refCount: The element's reference count. When this reaches 0, the element+;    is free'd.+%stack_element = type { i8, i8*, i32 }++; A "volatile", non-reused stack element wrapper which is used for the+; actual stack elements, i. e. the stack is a linked list of this type.+;+; This also double as a list element since lists need to be+; able to store all the types that can be pushed onto the stack.+;+; This struct contains two pointers which point (in this order):+;   a) to the real %stack_element in question (first member) and+;   b) to the next %stack_wrapper element in the linked list that makes up+;      the stack (second member).+;+; This is all needed because e. g. Rail variables can be used to+; push the same %stack_element onto the stack multiple times -- while+; the data and the reference count need to be shared by all these+; %stack_element structs, they need to have different nextElement pointers+; (so that the linked list can be a proper linked list). This wrapper type+; solves that issue by introducing yet another layer of abstraction, allowing+; us to reference the same %stack_element multiple times, while keeping a proper+; linked list.+%stack_wrapper = type { %stack_element*, %stack_wrapper* }++; Definitions for lambda push and pop+; The first Element is a pointer to the lambda funtion, the second is a+; pointer to the symbol table for the lambda +%struct.table = type { i8*, %stack_element*, %struct.table* }+%lambda_element = type {i32 (%struct.table*)**, %struct.table*}++; Global variables+@stack = global %stack_wrapper* null  ; Linked list of stack_element structs.+@stack_size = global i64 0            ; Current number of elements on the stack.+++; Constants+@err_type_mismatch = private unnamed_addr constant [16 x i8] c"Type mismatch!\0A\00"+@err_unhandled_type = private unnamed_addr constant [30 x i8] c"Cannot unref unhandled type!\0A\00"+@err_not_bool = private unnamed_addr constant [29 x i8] c"Stack value was not 0 or 1!\0A\00"+@err_empty_list = private unnamed_addr constant [13 x i8] c"Empty list!\0A\00"+@err_num_conv = constant [42 x i8] c"Cannot convert stack element to integer!\0A\00"+@type_string = unnamed_addr constant [7 x i8] c"string\00"+@type_lambda = unnamed_addr constant [7 x i8] c"lambda\00"+@type_list = unnamed_addr constant [5 x i8] c"list\00"+@type_nil = unnamed_addr constant [4 x i8] c"nil\00"++; External declarations++; C standard library variables/functions+declare void @free(i8*)+declare i8* @malloc(i16 zeroext) ; void *malloc(size_t) and size_t is 16 bits long (SIZE_MAX)+declare signext i32 @snprintf(i8*, ...)+declare signext i32 @strtol(i8*, i8**, i32 signext)+declare i8* @xcalloc(i16 zeroext, i16 zeroext)+declare i8* @xstrdup(i8*)++; Own external LLVM variables/functions+@float_to_str = external global [3 x i8]+@int_to_str = external global [3 x i8]++declare void @crash(i1)+declare void @underflow_assert()+declare void @list_unref_elements(%stack_element*)+++; Function definitions++; Get number of element on the stack+define i64 @stack_get_size() {+  %sz = load i64* @stack_size+  ret i64 %sz+}++; Creates a new stack_element with a reference count of 1.+define %stack_element* @stack_element_new(i8 %dataType, i8* %dataPtr) {+  ; How many bytes do we need to allocate for a single stack element struct?+  ; getelementptr abuse taken from:+  ; http://nondot.org/sabre/LLVMNotes/SizeOf-OffsetOf-VariableSizedStructs.txt+  %elem_size0 = getelementptr %stack_element* null, i32 1+  %elem_size1 = ptrtoint %stack_element* %elem_size0 to i16++  ; Now we can allocate the memory.+  %element0 = call i8* @xcalloc(i16 1, i16 %elem_size1)+  %element1 = bitcast i8* %element0 to %stack_element*++  ; %element1 now can be treated like an element struct. Yay!+  call void @stack_element_set_type(%stack_element* %element1, i8 %dataType)+  call void @stack_element_set_data(%stack_element* %element1, i8* %dataPtr)++  ; Finally, increment the reference count so that it is exactly 1.+  call void @stack_element_ref(%stack_element* %element1)++  ; That's it!+  ret %stack_element* %element1+}++; Decrement refcount of stack element+; If new refcount is zero, free the stack element and it's data+define void @stack_element_unref(%stack_element* %element) {+  %refcount = call i32(%stack_element*)* @stack_element_get_refcount(%stack_element* %element)+  %refcount_1 = sub i32 %refcount, 1+  %cond = icmp eq i32 %refcount_1, 0+  br i1 %cond, label %free_data, label %update_refcount++free_data:+  %data = call i8* @stack_element_get_data(%stack_element* %element)+  %type = call i8 @stack_element_get_type(%stack_element* %element)+  switch i8 %type, label %unhandled_type+    [+      i8 0, label %free_string+      i8 1, label %free_list+      i8 2, label %free_lambda+    ]++unhandled_type:+  %err_unhandled_type = getelementptr [30 x i8]* @err_unhandled_type, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %err_unhandled_type)+  call void @crash(i1 0)+  ret void++free_string:+  call void @free(i8* %data)+  br label %free_element++free_list:+  call void @list_unref_elements(%stack_element* %element)+  br label %free_element++free_lambda:+  call void @free(i8* %data)+  br label %free_element++free_element:+  %mem = bitcast %stack_element* %element to i8*+  call void @free(i8* %mem)+  br label %finished++update_refcount:+  call void(%stack_element*, i32)* @stack_element_set_refcount(%stack_element* %element, i32 %refcount_1)+  br label %finished++finished:+  ret void+}++; free() a stack element and optionally, free the data it contains as well+; (i. e. the memory pointed to by the dataPtr member).+;+; Returns the dataPtr if %free_data == 1 and null otherwise.+;+; TODO: This should probably decrement the reference count and only do something+;       if it is 0 after decrementing.+define i8* @stack_element_free(%stack_element* %element, i1 %free_data) {+top:+  %data = call i8* @stack_element_get_data(%stack_element* %element)+  br i1 %free_data, label %do_free_data, label %free_stack_struct++do_free_data:+  ; TODO: Check type here and free lists (type 1) correctly, i. e. iteratively.+  ;       (Or rather: Decrement the reference count of each list element)+  call void @free(i8* %data)++  br label %free_stack_struct++free_stack_struct:+  %ret = phi i8* [ %data, %top ], [ null, %do_free_data ]++  %mem = bitcast %stack_element* %element to i8*+  call void @free(i8* %mem)++  ret i8* %ret+}++; Increment the reference count of a stack_element.+define void @stack_element_ref(%stack_element* %element) {+  %refCount = call i32 @stack_element_get_refcount(%stack_element* %element)+  %newRefCount = add i32 %refCount, 1+  call void @stack_element_set_refcount(%stack_element* %element, i32 %newRefCount)++  ret void+}++; Get the type of the data in a stack_element struct.+;+; See the definition of %stack_element for a description of+; possible type values.+define i8 @stack_element_get_type(%stack_element* %element) {+  ; dataType is member #0+  %dataType0 = getelementptr %stack_element* %element, i32 0, i32 0+  %dataType1 = load i8* %dataType0+  ret i8 %dataType1+}++; Set the type of the data in a stack_element struct.+;+; See the definition of %stack_element for a description of+; possible type values.+define void @stack_element_set_type(%stack_element* %element, i8 %type) {+  ; dataType is member #0+  %dataTypeDestPtr = getelementptr %stack_element* %element, i32 0, i32 0+  store i8 %type, i8* %dataTypeDestPtr++  ret void+}++; Get the raw, uncasted data pointer of a stack_element struct.+;+; Crashes the program on errors.+define i8* @stack_element_get_data(%stack_element* %element) {+  ; dataPtr is member #1+  %dataPtr0 = getelementptr %stack_element* %element, i32 0, i32 1+  %dataPtr1 = load i8** %dataPtr0+  ret i8* %dataPtr1+}++; Get data from stack as an in integer numeral+define i64 @stack_element_get_int_data(%stack_element* %element) {+  ; Make sure we are operating on a string.+  call void @stack_element_assert_type(%stack_element* %element, i8 0)++  ; get raw data...+  %data = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %element)++  ; ...and convert it to an integer/long.+  %endptrptr = alloca i8*+  store i8* null, i8** %endptrptr+  %int0 = call i32 @strtol(i8* %data, i8** %endptrptr, i32 10)+  %int1 = sext i32 %int0 to i64++  ; Was everything converted?+  %endptr = load i8** %endptrptr+  %not_null0 = icmp ne i8* %endptr, null+  br i1 %not_null0, label %error_check, label %okay++error_check:+  ; Need to check if the first byte is 0, i. e. if everything+  ; up to the terminating null byte has been converted.+  %first_byte = load i8* %endptr+  %not_null1 = icmp ne i8 %first_byte, 0+  br i1 %not_null1, label %bail_out, label %okay++bail_out:+  ; Error -- crash!+  %msg = getelementptr [42 x i8]* @err_num_conv, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %msg)+  call void @crash(i1 0)++  ret i64 -1++okay:+ ret i64 %int1+}++; Set the raw data pointer of a stack_element struct.+define void @stack_element_set_data(%stack_element* %element, i8* %data) {+  ; dataPtr is member #1+  %dataPtr = getelementptr %stack_element* %element, i32 0, i32 1+  store i8* %data, i8** %dataPtr++  ret void+}++; Set the reference count of a stack_element struct.+define void @stack_element_set_refcount(%stack_element* %element, i32 %refCount) {+  ; refCount is member #2+  %refCountDestPtr = getelementptr %stack_element* %element, i32 0, i32 2+  store i32 %refCount, i32* %refCountDestPtr++  ret void+}++; Get the reference count of a stack_element struct.+define i32 @stack_element_get_refcount(%stack_element* %element) {+  ; refCount is member #2+  %refCount0 = getelementptr %stack_element* %element, i32 0, i32 2+  %refCount1 = load i32* %refCount0++  ret i32 %refCount1+}++; Create a new %stack_wrapper struct.+define %stack_wrapper* @stack_wrapper_new(%stack_element* %stackElementPtr, %stack_wrapper* %nextWrapperPtr) {+  ; How many bytes do we need to allocate for a single stack wrapper struct?+  ; getelementptr abuse taken from:+  ; http://nondot.org/sabre/LLVMNotes/SizeOf-OffsetOf-VariableSizedStructs.txt+  %wrap_size0 = getelementptr %stack_wrapper* null, i32 1+  %wrap_size1 = ptrtoint %stack_wrapper* %wrap_size0 to i16++  ; Now we can allocate the memory.+  %wrapper0 = call i8* @xcalloc(i16 1, i16 %wrap_size1)+  %wrapper1 = bitcast i8* %wrapper0 to %stack_wrapper*++  ; %wrapper1 now can be treated like a wrapper struct.+  call void @stack_wrapper_set_element(%stack_wrapper* %wrapper1, %stack_element* %stackElementPtr)+  call void @stack_wrapper_set_next(%stack_wrapper* %wrapper1, %stack_wrapper* %nextWrapperPtr)++  ; That's it!+  ret %stack_wrapper* %wrapper1+}++; Free a %stack_wrapper struct.+;+; Does not free the %stack_element struct hidden by the wrapper.+define void @stack_wrapper_free(%stack_wrapper* %wrapper) {+    %mem = bitcast %stack_wrapper* %wrapper to i8*+    call void @free(i8* %mem)++    ret void+}++; Get the "real" %stack_element behind a stack_wrapper struct.+define %stack_element* @stack_wrapper_get_element(%stack_wrapper* %wrapper) {+    ; stackElementPtr is member #0+    %stackElement0 = getelementptr %stack_wrapper* %wrapper, i32 0, i32 0+    %stackElement1 = load %stack_element** %stackElement0++    ret %stack_element* %stackElement1+}++; Set the "real" %stack_element behind a stack_wrapper struct.+define void @stack_wrapper_set_element(%stack_wrapper* %wrapper, %stack_element* %element) {+    ; stackElementPtr is member #0+    %stackElementPtr = getelementptr %stack_wrapper* %wrapper, i32 0, i32 0+    store %stack_element* %element, %stack_element** %stackElementPtr++    ret void+}++; Get the "next wrapper" pointer of a stack_wrapper struct.+define %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %wrapper) {+  ; nextWrapperPtr is member #1+  %nextWrapper0 = getelementptr %stack_wrapper* %wrapper, i32 0, i32 1+  %nextWrapper1 = load %stack_wrapper** %nextWrapper0++  ret %stack_wrapper* %nextWrapper1+}++; Set the "next wrapper" pointer of a stack_wrapper struct.+define void @stack_wrapper_set_next(%stack_wrapper* %wrapper, %stack_wrapper* %next) {+  ; nextWrapperPtr is member #1+  %nextPtr = getelementptr %stack_wrapper* %wrapper, i32 0, i32 1+  store %stack_wrapper* %next, %stack_wrapper** %nextPtr++  ret void+}++; Assert that the data in the stack_element has the passed type.+;+; If the types do not match, crash the program with an appropriate error message.+; This actually checks if the dataType member is equal to %want_type.+define void @stack_element_assert_type(%stack_element* %element, i8 %want_type) {+  %actual_type = call i8 @stack_element_get_type(%stack_element* %element)+  %is_valid = icmp eq i8 %actual_type, %want_type+  br i1 %is_valid, label %valid_type, label %invalid_type++valid_type:+  ; All good. Do nothing.+  ret void++invalid_type:+  ; Bail out!+  %err_type_mismatch = getelementptr [16 x i8]* @err_type_mismatch, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %err_type_mismatch)+  call void @crash(i1 0)++  ret void+}++; Assert that the data in the stack_element is a non-empty list.+;+; Crashes the program if the assertion fails.+define void @stack_element_assert_is_non_empty_list(%stack_element* %element) {+  ; Type 1 is list.+  call void @stack_element_assert_type(%stack_element* %element, i8 1)++  %data = call i8* @stack_element_get_data(%stack_element* %element)+  %is_null = icmp eq i8* %data, null+  br i1 %is_null, label %l_empty_list, label %l_non_empty_list++l_empty_list:+  ; Bad. Crash.+  %err_empty_list = getelementptr [13 x i8]* @err_empty_list, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %err_empty_list)+  call void @crash(i1 0)++  ret void++l_non_empty_list:+    ; All good.+    ret void+}++; Get (but do not remove) the topmost %stack_wrapper struct.+;+; Crashes the program if the stack is empty.+define %stack_wrapper* @peek_wrapper() {+  ; 1. Make sure we can peek something.+  call void @underflow_assert()++  ; 2. Do the actual peek.+  %stack = load %stack_wrapper** @stack++  ret %stack_wrapper* %stack+}++; Pop a stack_element struct from the stack.+define %stack_element* @pop_struct() {+  ; 1. Pop the stack and get the topmost wrapper.+  %stack = call %stack_wrapper* @peek_wrapper()+  %next = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %stack)+  store %stack_wrapper* %next, %stack_wrapper** @stack++  ; Get the wrapped stack_element and free the wrapper.+  %element = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %stack)+  call void @stack_wrapper_free(%stack_wrapper* %stack)++  ; 2. Decrement the stack size.+  %stack_size0 = load i64* @stack_size+  %stack_size1 = sub i64 %stack_size0, 1+  store i64 %stack_size1, i64* @stack_size++  ; 3. That's it!+  ret %stack_element* %element+}++; Push a stack_element struct onto the stack+define void @push_struct(%stack_element* %element) {+  ; 1. Push new element by creating and pushing a new wrapper,+  ;    updating its "next" pointer to the first element of the current stack.+  ;+  ;    NB: Do NOT use peek_wrapper() here since that will crash the program+  ;        if the stack is empty -- making it impossible to push a struct+  ;        onto the empty stack.+  %curr_head = load %stack_wrapper** @stack+  %new_head = call %stack_wrapper* @stack_wrapper_new(%stack_element* %element, %stack_wrapper* %curr_head)+  store %stack_wrapper* %new_head, %stack_wrapper** @stack++  ; 2. Increment stack size.+  %stack_size0 = call i64 @stack_get_size()+  %stack_size1 = add i64 %stack_size0, 1+  store i64 %stack_size1, i64* @stack_size++  ret void+}++; Pop a string from the stack.+;+; Crashes if the type of the topmost element is not "string".+;+; XXX: THIS IS A LEGACY FUNCTION. DO NOT USE IT IN NEW CODE.+;      New code should use proper reference counting.+define i8* @pop_string() {+  ; 1. Pop the stack.+  %stack = call %stack_element* @pop_struct()++  ; 2. Is the type string? If not, crash.+  call void @stack_element_assert_type(%stack_element* %stack, i8 0)++  ; 3. It's a string, everything is fine. Extract the string.+  %buf = call i8* @stack_element_get_data(%stack_element* %stack)++  ; 4. Finally, free the stack element.+  call i8* @stack_element_free(%stack_element* %stack, i1 0)++  ret i8 *%buf+}++; Push a string onto the stack, creating a new stack_element struct+; with a reference count of 1.+;+; The string must already be allocated _ON THE HEAP_.+define %stack_element* @push_string_ptr(i8* %str) {+  ; 1. Create and push a new stack_element.+  ;    NB: Stack size is incremented by push_struct().+  %elem = call %stack_element* @stack_element_new(i8 0, i8* %str)+  call void @push_struct(%stack_element* %elem)++  ; 2. That's it!+  ret %stack_element* %elem+}++; strdup() a string and push it onto the stack, creating a new stack_element struct+; with a reference count of 1.+define %stack_element* @push_string_cpy(i8* %str) {+  %str_copied = call i8* @xstrdup(i8* %str)+  %ret = call %stack_element* @push_string_ptr(i8* %str_copied)++  ret %stack_element* %ret+}++; pops element from stack and converts to integer+; returns the element, in case of error crashes the program+define i64 @pop_int() {+  ; Get top element of stack.+  %top = call %stack_element* @pop_struct()++  ; Now convert it to an int.+  %int = call i64 @stack_element_get_int_data(%stack_element* %top)++  ; Decrement refcount and return+  call void @stack_element_unref(%stack_element* %top)+  ret i64 %int+}++define i64 @pop_bool(){+  ;pop an int element from stack+  %top = call i64 @pop_int()++  ;check whether it is 0 or 1+  switch i64 %top, label %error [ i64 0, label %its_bool+                                  i64 1, label %its_bool ]++error:+  ; Bail out!+  %err_not_bool = getelementptr [29 x i8]* @err_not_bool, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %err_not_bool)+  call void @crash(i1 0)+  ret i64 -1++its_bool:+  ret i64 %top+}++define void @push_int(i64 %top_int)+{+  ; allocate memory to store string in+  ; TODO: Make sure this is free()'d at _some_ point during+  ;       program execution.+  %buffer_addr = call i8* @malloc(i16 128)+  %to_str_ptr = getelementptr [3 x i8]* @int_to_str, i64 0, i64 0++  ; convert to string+  call i32(i8*, ...)* @snprintf(+          i8* %buffer_addr, i16 128, i8* %to_str_ptr, i64 %top_int)++  ; push on stack+  call %stack_element* @push_string_ptr(i8* %buffer_addr)++  ret void+}++define void @push_float(double %top_float)+{+  ; allocate memory to store string in+  ; TODO: Make sure this is free()'d at _some_ point during+  ;       program execution.+  %buffer_addr = call i8* @malloc(i16 128)+  %to_str_ptr = getelementptr [3 x i8]* @float_to_str, i64 0, i64 0++  ; convert to string+  call i32(i8*, ...)* @snprintf(+          i8* %buffer_addr, i16 128, i8* %to_str_ptr, double %top_float)++  ; push on stack+  call %stack_element* @push_string_ptr(i8* %buffer_addr)++  ret void+}++; takes a function pointer and a table pointer and pushes both as a struct onto the stack+define void @push_lambda(i32 (%struct.table*)** %function_ptr, %struct.table* %table_ptr)+{+  %l = call i8* @malloc(i16 16)+  %l_ptr = bitcast i8* %l to %lambda_element*+  ; store function pointer+  %l_ptr_func = getelementptr inbounds %lambda_element* %l_ptr, i32 0, i32 0+  store i32 (%struct.table*)** %function_ptr, i32 (%struct.table*)*** %l_ptr_func+  ; store tablre pointer+  %l_ptr_table = getelementptr inbounds %lambda_element* %l_ptr, i32 0, i32 1+  store %struct.table* %table_ptr, %struct.table** %l_ptr_table++  ; push element onto the stack+  %l_elem = call %stack_element* @stack_element_new(i8 2, i8* %l)+  call void @push_struct(%stack_element* %l_elem)+  ret void+}++; pops form stack and checks if stack_element is a lambda+; returns a pointer to the lambda element+define %lambda_element* @pop_lambda()+{+  %l_elem = call %stack_element* @pop_struct()+  +  ; check if struct is a lambda, if not crash+  call void @stack_element_assert_type(%stack_element* %l_elem, i8 2)++  %l_ptr = call i8* @stack_element_get_data(%stack_element* %l_elem)+  %l_ptr_bitcast = bitcast i8* %l_ptr to %lambda_element*+  ret %lambda_element* %l_ptr_bitcast+}++; returns the pointer to the lambda function+define i32 (%struct.table*)* @get_lambda_pointer(%lambda_element* %l){+  %l_func_ptr = getelementptr inbounds %lambda_element* %l, i32 0, i32 0+  %l_func = load i32 (%struct.table*)*** %l_func_ptr+  %l_func2 = load i32 (%struct.table*)** %l_func+  ret i32 (%struct.table*)* %l_func2+}++; returns the pointer to the lambda symbol table+define %struct.table* @get_lambda_table(%lambda_element* %l){+  %l_table_ptr = getelementptr inbounds %lambda_element* %l, i32 0, i32 1+  %l_table = load %struct.table** %l_table_ptr+  ret %struct.table* %l_table+}
+ src/RailCompiler/list.ll view
@@ -0,0 +1,214 @@+; Module      : LLVM backend - list implementation+; Description : Contains our list implementation - based on a linked list (and in fact+;               uses the same data structures as our linked stack).+; Maintainers : Tilman Blumenbach et al.+; License     : MIT+;+; Lists are implemented as linked lists of stack_wrapper elements, i. e. just like our+; normal linked stack. The data type "list" is represented as a stack_element with type+; 1 and a data pointer pointing to the head of the aforementioned stack_wrapper linked list.+; Thus, an empty list is a stack_element with type 1 and a null data pointer.+++; Types++; Types defined in linked_stack.ll.+%stack_element = type opaque+%stack_wrapper = type opaque+++; External declarations++; Own external LLVM variables/functions+declare %stack_element* @stack_element_new(i8, i8*)+declare void @stack_element_unref(%stack_element*)+declare void @stack_element_set_data(%stack_element*, i8*)+declare i8* @stack_element_get_data(%stack_element*)+declare %stack_wrapper* @stack_wrapper_new(%stack_element*, %stack_wrapper*)+declare void @stack_wrapper_free(%stack_wrapper*)+declare %stack_element* @stack_wrapper_get_element(%stack_wrapper*)+declare %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper*)+declare void @push_struct(%stack_element*)+declare %stack_element* @pop_struct()+declare void @stack_element_assert_type(%stack_element*, i8)+declare void @stack_element_assert_is_non_empty_list(%stack_element*)+declare i1 @do_equal(%stack_element* %struct_a, %stack_element*)+++; Function definitions++; Create a new, empty list (also called "nil") with a refcount of 1.+define %stack_element* @list_new() {+    ; Type 1 is reserved for the "list" type.+    ; Empty lists are simply stack_element structs with a null data pointer.+    %elm = call %stack_element* @stack_element_new(i8 1, i8* null)+    ret %stack_element* %elm+}++; Decrement the refcount of each element of a list.+;+; This does not free the stack_element which holds the list itself.+; That one is free'd by stack_element_unref().+define void @list_unref_elements(%stack_element* %list) {+top:+    %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list)+    %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper*+    br label %free_list_elements++free_list_elements:+    %curr_wrapper = phi %stack_wrapper* [ %head_wrapper1, %top ], [ %next_wrapper, %free_one_list_element ]++    %is_null = icmp eq %stack_wrapper* %curr_wrapper, null+    br i1 %is_null, label %done, label %free_one_list_element++free_one_list_element:+    %next_wrapper = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper)+    %elm = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper)+    call void @stack_element_unref(%stack_element* %elm)+    call void @stack_wrapper_free(%stack_wrapper* %curr_wrapper)++    br label %free_list_elements++done:+    ; Nothing to do since the list is empty.+    ret void+}++; Prepend a stack_element to a list (also called "cons").+;+; Returns its first parameter.+define %stack_element* @list_prepend(%stack_element* %list, %stack_element* %element) {+    ; A list contains a stack_wrapper as its data. This is the wrapped head of the list.+    %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list)+    %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper*++    ; Now create a new wrapper for the element we want to prepend.+    %new_head_wrapper = call %stack_wrapper* @stack_wrapper_new(%stack_element* %element, %stack_wrapper* %head_wrapper1)++    ; This is the new list head, so store it in the topmost stack_element.+    %data = bitcast %stack_wrapper* %new_head_wrapper to i8*+    call void @stack_element_set_data(%stack_element* %list, i8* %data)++    ; That's it!+    ret %stack_element* %list+}++; Pop the head off a non-empty list.+define %stack_element* @list_pop(%stack_element* %list) {+    ; Get the top stack_wrapper of the list.+    %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list)+    %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper*++    ; Get the contents of the wrapper.+    %top_elm = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %head_wrapper1)++    ; What's the new head of the list?+    %new_head0 = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %head_wrapper1)+    %new_head1 = bitcast %stack_wrapper* %new_head0 to i8*+    call void @stack_element_set_data(%stack_element* %list, i8* %new_head1)++    ; Now we can free the old topmost wrapper.+    call void @stack_wrapper_free(%stack_wrapper* %head_wrapper1)++    ; That's it!+    ret %stack_element* %top_elm+}++; Compare two lists.+;+; Returns 1 if both lists are equal or 0 otherwise.+;+; Crashes the program on errors (prints an appropriate error message).+define i1 @list_equal(%stack_element* %list_a, %stack_element* %list_b) {+top:+    ; Get the top stack_wrappers of both lists.+    %head_wrapper_a0 = call i8* @stack_element_get_data(%stack_element* %list_a)+    %head_wrapper_a1 = bitcast i8* %head_wrapper_a0 to %stack_wrapper*++    %head_wrapper_b0 = call i8* @stack_element_get_data(%stack_element* %list_b)+    %head_wrapper_b1 = bitcast i8* %head_wrapper_b0 to %stack_wrapper*++    br label %compare_lists++compare_lists:+    %curr_wrapper_a = phi %stack_wrapper* [ %head_wrapper_a1, %top ], [ %next_wrapper_a, %compare_elements ]+    %curr_wrapper_b = phi %stack_wrapper* [ %head_wrapper_b1, %top ], [ %next_wrapper_b, %compare_elements ]++    ; If at least one wrapper is null, we may either have reached the end+    ; of BOTH lists (which means that they are equal) or one list is shorter+    ; than the other, which means that they are NOT equal.+    %wrapper_a_is_null = icmp eq %stack_wrapper* %curr_wrapper_a, null+    %wrapper_b_is_null = icmp eq %stack_wrapper* %curr_wrapper_b, null+    %at_least_one_null = or i1 %wrapper_a_is_null, %wrapper_b_is_null+    br i1 %at_least_one_null, label %null_check, label %compare_elements++null_check:+    ; If both wrappers are null, we are finished and the lists are equal.+    ; Otherwise one list is shorter than the other and the lists are NOT+    ; equal.+    %both_null = icmp eq %stack_wrapper* %curr_wrapper_a, %curr_wrapper_b+    br i1 %both_null, label %end_equal, label %end_not_equal++compare_elements:+    ; We have two elements which are both not null, so we can compare them.+    ; Set next pointers:+    %next_wrapper_a = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper_a)+    %next_wrapper_b = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper_b)++    ; Get the wrapped stack elements.+    %elm_a = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper_a)+    %elm_b = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper_b)++    ; Now we can do the actual comparison.+    %are_equal = call i1 @do_equal(%stack_element* %elm_a, %stack_element* %elm_b)+    ; If the elements are equal, check the next pair, else exit.+    br i1 %are_equal, label %compare_lists, label %end_not_equal++end_equal:+    ret i1 1++end_not_equal:+    ret i1 0+}+++; Convenience functions for use in generated code.++; Push nil (an empty list) onto the stack.+define void @gen_list_push_nil() {+    %list = call %stack_element* @list_new()+    call void @push_struct(%stack_element* %list)+    ret void+}++; Prepend the topmost element to the list, which is the stack element after+; the topmost element, and push the resulting list.+define void @gen_list_cons() {+    %elm_to_prepend = call %stack_element* @pop_struct()+    %list = call %stack_element* @pop_struct()++    ; Make sure %list is a list.+    call void @stack_element_assert_type(%stack_element* %list, i8 1)++    ; Now we can prepend the element to the list...+    call %stack_element* @list_prepend(%stack_element* %list, %stack_element* %elm_to_prepend)++    ; ...and push the list again.+    call void @push_struct(%stack_element* %list)++    ret void+}++define void @gen_list_breakup() {+    %list = call %stack_element* @pop_struct()+    call void @stack_element_assert_is_non_empty_list(%stack_element* %list)++    ; Now pop the topmost list element.+    %top = call %stack_element* @list_pop(%stack_element* %list)++    ; Now we can push the list and its former first element again.+    call void @push_struct(%stack_element* %list)+    call void @push_struct(%stack_element* %top)++    ret void+}
+ src/RailCompiler/math.ll view
@@ -0,0 +1,670 @@+; Module      : LLVM backend - general math functions+; Description : Contains LLVM functions for mathematical operations like addition etc.+; Maintainers : Sascha Zinke+; License     : MIT+;+; These functions are used by our LLVM backend and operate directly on the stack --+; see stack.ll.++@err_numeric = external global [56 x i8]+@err_type = external global [14 x i8]+@err_zero = external global [18 x i8]+@popped = external global [13 x i8]++%stack_element = type opaque+%struct.stack_elem = type { i32, %union.anon }+%union.anon = type { i8* }++declare i8* @stack_element_get_data(%stack_element* %element)+declare void @stack_element_unref(%stack_element* %element)+declare i32 @get_stack_elem(i8*, %struct.stack_elem*)+declare %stack_element* @push_string_ptr(i8* %str)+declare %stack_element* @push_string_cpy(i8* %str)+declare %stack_element* @pop_struct()+declare signext i32 @printf(i8*, ...)+declare void @push_float(double)+declare void @underflow_assert()+declare void @push_int(i64)+declare i8* @pop_string()+declare void @crash(i1)++@main.number_b  = private unnamed_addr constant [4 x i8] c"3.0\00"+@main.number_a = private unnamed_addr constant [4 x i8] c"0.0\00"++define i32 @main_math() {+  ; push two numbers on the stack+  %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0   +  %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0   ++  call %stack_element* @push_string_cpy(i8* %number0)+  call %stack_element* @push_string_cpy(i8* %number1)++  call i32 @div()+  %result = call i8* @pop_string()+  call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]*+              @popped, i32 0, i32 0), i8* %result)++  ret i32 0+}++define i32 @mult() {+  ; return value of this function+  %func_result = alloca i32, align 4++  ; allocate memory on stack to hold our structures that contains the type+  ; of stack element and its casted value+  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8++  ; get top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get second top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]++;##############################################################################+;                        integer multiplication+;##############################################################################++assume_b_int:+  ; check whether it is 1 (aka INT).+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %mult_int, label %exit_with_invalid_type++mult_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64*+  %ival_a = load i64* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64*+  %ival_b = load i64* %ival_b_cast, align 4++  ; add the two integers and store result on the stack+  %ires = mul i64 %ival_a, %ival_b+  call void(i64)* @push_int(i64 %ires)+  br label %exit_with_success++;##############################################################################+;                        floating point multiplication+;##############################################################################++assume_b_float:+  ; check whether it is 2 (aka FLOAT).+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %mult_float, label %exit_with_invalid_type++mult_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4+  %fval_a_d = fpext float %fval_a to double++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4+  %fval_b_d = fpext float %fval_b to double++  ; mult the two floats and store result on the stack+  %fres= fmul double %fval_a_d, %fval_b_d+  call void(double)* @push_float(double %fres)+  br label %exit_with_success++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++define i32 @rem() {+  ; return value of this function+  %func_result = alloca i32, align 4++  ; allocate memory on stack to hold our structures that contains the type+  ; of stack element and its casted value+  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8++  ; get top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get second top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]++;##############################################################################+;                        integer remainder+;##############################################################################++assume_b_int:+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %rem_int, label %exit_with_invalid_type++rem_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32*+  %ival_a = load i32* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32*+  %ival_b = load i32* %ival_b_cast, align 4++  ; add the two integers and store result on the stack+  %ires = srem i32 %ival_a, %ival_b+  %lres = sext i32 %ires to i64+  call void(i64)* @push_int(i64 %lres)+  br label %exit_with_success++;##############################################################################+;                        floating point remainder+;##############################################################################++assume_b_float:+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %rem_float, label %exit_with_invalid_type++rem_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4+  %fval_a_d = fpext float %fval_a to double++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4+  %fval_b_d = fpext float %fval_b to double++  ; rem the two floats and store result on the stack+  %fres= frem double %fval_a_d, %fval_b_d+  call void(double)* @push_float(double %fres)+  br label %exit_with_success++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type: +  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++define i32 @sub() {+  ; return value of this function+  %func_result = alloca i32, align 4++  ; allocate memory on stack to hold our structures that contains the type+  ; of stack element and its casted value+  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8++  ; get top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get second top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]++;##############################################################################+;                        integer subtraction+;##############################################################################++assume_b_int:+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %sub_int, label %exit_with_invalid_type++sub_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64*+  %ival_a = load i64* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64*+  %ival_b = load i64* %ival_b_cast, align 4++  ; add the two integers and store result on the stack+  %ires = sub i64 %ival_a, %ival_b+  call void(i64)* @push_int(i64 %ires)+  br label %exit_with_success++;##############################################################################+;                        floating point subtraction+;##############################################################################++assume_b_float:+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %sub_float, label %exit_with_invalid_type++sub_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4+  %fval_a_d = fpext float %fval_a to double++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4+  %fval_b_d = fpext float %fval_b to double++  ; sub the two floats and store result on the stack+  %fres= fsub double %fval_a_d, %fval_b_d+  call void(double)* @push_float(double %fres)+  br label %exit_with_success++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++define i32 @add() {+  ; return value of this function+  %func_result = alloca i32, align 4++  ; allocate memory on stack to hold our structures that contains the type+  ; of stack element and its casted value+  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8++  ; get top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get second top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1+  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]++;##############################################################################+;                        integer addition+;##############################################################################++assume_b_int:+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %add_int, label %exit_with_invalid_type++add_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64*+  %ival_a = load i64* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64*+  %ival_b = load i64* %ival_b_cast, align 4++  ; add the two integers and store result on the stack+  %ires = add i64 %ival_a, %ival_b+  call void(i64)* @push_int(i64 %ires)+  br label %exit_with_success++;##############################################################################+;                        floating point addition+;##############################################################################++assume_b_float:+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %add_float, label %exit_with_invalid_type++add_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4+  %fval_a_d = fpext float %fval_a to double++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4+  %fval_b_d = fpext float %fval_b to double++  ; add the two floats and store result on the stack+  %fres= fadd double %fval_a_d, %fval_b_d+  call void(double)* @push_float(double %fres)+  br label %exit_with_success++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:  +  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++define i32 @div() {+  ; return value of this function+  %func_result = alloca i32, align 4++  ; allocate memory on stack to hold our structures that contains the type+  ; of stack element and its casted value+  %new_elem_a = alloca %struct.stack_elem, align 8+  %new_elem_b = alloca %struct.stack_elem, align 8++  ; get top of stack+  call void @underflow_assert()+  %struct_b = call %stack_element*()* @pop_struct()+  %number_b = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_b)++  ; get second top of stack+  call void @underflow_assert()+  %struct_a = call %stack_element*()* @pop_struct()+  %number_a = call i8*(%stack_element*)* @stack_element_get_data(+                                                   %stack_element* %struct_a)++  ; get type of number_a+  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)+  %is_zero_a = icmp slt i32 %ret_a, 0+  br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b++get_stack_elem_b:+  ; get type of number_b+  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)+  %is_zero_b = icmp slt i32 %ret_b, 0+  br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types++get_types:+  ; type of a+  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0+  %type_a = load i32* %type_a_ptr, align 4+  %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1++  ; type of b+  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0+  %type_b = load i32* %type_b_ptr, align 4+  %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1++  switch i32 %type_a, label %exit_with_invalid_type [+                                        i32 1, label %assume_b_int+                                        i32 2, label %assume_b_float]+++;##############################################################################+;                        integer division+;##############################################################################++assume_b_int:+  %is_int_b = icmp eq i32 %type_b, 1+  br i1 %is_int_b, label %div_int, label %exit_with_invalid_type++div_int:+  ; get new_elem_a.ival that contains the casted integer value+  %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32*+  %ival_a = load i32* %ival_a_cast, align 4++  ; get new_elem_b.ival that contains the casted integer value+  %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32*+  %ival_b = load i32* %ival_b_cast, align 4++  ; prevent division by zero+  %div_by_zero = icmp eq i32 %ival_b, 0+  br i1 %div_by_zero, label %exit_with_zero, label %div_int_ok++div_int_ok:+  ; divide the two integers and store result on the stack+  %ires = sdiv i32 %ival_a, %ival_b+  %lres = sext i32 %ires to i64++  call void(i64)* @push_int(i64 %lres)+  br label %exit_with_success++;##############################################################################+;                        floating point division+;##############################################################################++assume_b_float:+  %is_float_b = icmp eq i32 %type_b, 2+  br i1 %is_float_b, label %div_float, label %exit_with_invalid_type++div_float:+  ; get new_elem_a.fval that contains the float value+  %fval_a_cast = bitcast %union.anon* %val_a_ptr to float*+  %fval_a = load float* %fval_a_cast, align 4+  %fval_a_d = fpext float %fval_a to double++  ; get new_elem_b.fval that contains the float value+  %fval_b_cast = bitcast %union.anon* %val_b_ptr to float*+  %fval_b = load float* %fval_b_cast, align 4++  ; prevent division by zero+  %div_by_zero_f = fcmp oeq float %fval_b, 0.0+  br i1 %div_by_zero_f, label %exit_with_zero, label %div_float_ok++div_float_ok:+  ; divide the two floats and store result on the stack+  %fval_b_d = fpext float %fval_b to double+  %fres= fdiv double %fval_a_d, %fval_b_d+  call void(double)* @push_float(double %fres)+  br label %exit_with_success++exit_with_success:+  store i32 0, i32* %func_result+  br label %exit++exit_with_numeric_failure:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                       [56 x i8]* @err_numeric, i64 0, i64 0))+  br label %exit_with_failure++exit_with_zero: +  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [18 x i8]* @err_zero, i64 0, i64 0))+  br label %exit_with_failure++exit_with_invalid_type: +  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  br label %exit_with_failure++exit_with_failure:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  call void @crash(i1 0)+  br label %exit++exit:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b)+  %result = load i32* %func_result+  ret i32 %result+}++
src/RailCompiler/stack.ll view
@@ -1,1398 +1,552 @@-@stack = global [1000 x i8*] undef ; stack containing pointers to i8-@sp = global i64 0 ; global stack pointer (or rather: current number of elements)-@lookahead = global i32 -1  ; current lookahead for input from stdin.-                            ; -1 means no lookahead done yet.---; Constants-@to_str  = private unnamed_addr constant [3 x i8] c"%i\00"-@true = global [2 x i8] c"1\00"-@false = global [2 x i8] c"0\00"-@printf_str_fmt = private unnamed_addr constant [3 x i8] c"%s\00"-@crash_cust_str_fmt = private unnamed_addr constant [24 x i8] c"Crash: Custom error: %s\00"-@err_stack_underflow = private unnamed_addr constant [18 x i8] c"Stack underflow!\0A\00"-@err_eof = private unnamed_addr constant [9 x i8] c"At EOF!\0A\00"-@err_type = private unnamed_addr constant [14 x i8] c"Invalid type!\00"-@err_zero = private unnamed_addr constant [18 x i8] c"Division by zero!\00"---; External declarations-%FILE = type opaque--@stderr = external global %FILE*--declare signext i32 @atol(i8*)-declare i64 @strtol(i8*, i8**, i32 )-declare signext i32 @snprintf(i8*, ...)-declare signext i32 @printf(i8*, ...)-declare signext i32 @fprintf(%FILE*, i8*, ...)-declare float @strtof(i8*, i8**)-declare signext i32 @getchar()-declare i8* @malloc(i16 zeroext) ; void *malloc(size_t) and size_t is 16 bits long (SIZE_MAX)-declare i8* @calloc(i16 zeroext, i16 zeroext)-declare void @exit(i32 signext)---; Debugging stuff-@pushing = private unnamed_addr constant [14 x i8] c"Pushing [%s]\0A\00"-@popped  = private unnamed_addr constant [13 x i8] c"Popped [%s]\0a\00"-@msg = private unnamed_addr constant [5 x i8] c"msg\0a\00"---@int_to_str  = private unnamed_addr constant [3 x i8] c"%i\00"-@float_to_str  = private unnamed_addr constant [3 x i8] c"%f\00"--;typedef enum {INT = 1, FLOAT = 2, STRING = 3} elem_type;-;struct stack_elem {-;    elem_type type;-;    union {-;        int ival;-;        float fval;-;        char *sval;-;    };-;};-%struct.stack_elem = type { i32, %union.anon }-%union.anon = type { i8* }---@.str = private unnamed_addr constant [33 x i8] c"call int add with a=%i and b=%i\0A\00", align 1-@.str1 = private unnamed_addr constant [35 x i8] c"call float add with a=%f and b=%f\0A\00", align 1-@.str2 = private unnamed_addr constant [15 x i8] c"failed to add\0A\00", align 1----; Function definitions--; Get number of element on the stack-define i64 @stack_get_size() {-  %sp = load i64* @sp-  ret i64 %sp-}--; Push the stack size onto the stack-define void @underflow_check() {-  %stack_size = call i64 @stack_get_size()-  call void @push_int(i64 %stack_size)-  ret void-}--; Exit the program if stack is empty (prints error to stderr).-define void @underflow_assert() {-  %stack_size = call i64 @stack_get_size()-  %stack_empty = icmp eq i64 %stack_size, 0-  br i1 %stack_empty, label %uas_crash, label %uas_okay--uas_crash:-  %err = getelementptr [18 x i8]* @err_stack_underflow, i8 0, i8 0-  %stderr = load %FILE** @stderr-  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %err)-  call void @exit(i32 1)--  ret void--uas_okay:-  ret void-}--; Pop stack and print result string-define void @print() {-  ; TODO: Check if the top stack element is a string and crash if it is not.-  call void @underflow_assert()--  %fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0-  %val = call i8* @pop()-  call i32(i8*, ...)* @printf(i8* %fmt, i8* %val)--  ret void-}--; Pop stack, print result string to stderr and exit the program.-define void @crash(i1 %is_custom_error) {-  ; TODO: Check if the top stack element is a string and crash if it is not.-  call void @underflow_assert()--  br i1 %is_custom_error, label %custom_error, label %raw_error--custom_error:-  %cust_fmt = getelementptr [24 x i8]* @crash_cust_str_fmt, i8 0, i8 0-  br label %end--raw_error:-  %raw_fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0-  br label %end--end:-  %fmt = phi i8* [%raw_fmt, %raw_error], [%cust_fmt, %custom_error]-  %val = call i8* @pop()-  %stderr = load %FILE** @stderr-  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %fmt, i8* %val)--  ; Now, crash!-  call void @exit(i32 1)--  ret void-}--; Get a byte of input from stdin and push it.-; Crashes the program on errors.-define void @input() {-  %read = call i32 @input_get()-  %err = icmp slt i32 %read, 0-  br i1 %err, label %error, label %push--error:-  %at_eof = getelementptr [9 x i8]* @err_eof, i64 0, i64 0-  call void @push(i8* %at_eof)-  call void @crash(i1 0)-  ret void--push:-  %byte = trunc i32 %read to i8-  %buffer_addr = call i8* @calloc(i16 1, i16 2)-  store i8 %byte, i8* %buffer_addr-  call void @push(i8* %buffer_addr)--  ret void-}--; Get a byte of input from stdin. Returns < 0 on error.-; This can be used together with input_peek().-define i32 @input_get() {-  %lookahead = load i32* @lookahead-  %need_read = icmp slt i32 %lookahead, 0-  br i1 %need_read, label %ig_read, label %ig_lookahead--ig_lookahead:-  store i32 -1, i32* @lookahead-  ret i32 %lookahead--ig_read:-  %read = call i32 @getchar()-  ret i32 %read-}--; Peek a byte of input from stdin. Returns < 0 on error.-; Successive calls to this function without interspersed calls-; to input_read() return the same value.-define i32 @input_peek() {-  %read = call i32 @input_get()-  store i32 %read, i32* @lookahead-  ret i32 %read-}--; If stdin is at EOF, push 1, else 0.-define void @eof_check() {-  %peek = call i32 @input_peek()-  %is_eof = icmp slt i32 %peek, 0-  br i1 %is_eof, label %at_eof, label %not_at_eof--at_eof:-  %true = getelementptr [2 x i8]* @true, i8 0, i8 0-  call void @push(i8* %true)-  ret void--not_at_eof:-  %false = getelementptr [2 x i8]* @false, i8 0, i8 0-  call void @push(i8* %false)--  ret void-}--define void @push(i8* %str_ptr) {-  ; dereferencing @sp by loading value into memory-  %sp   = load i64* @sp--  ; get position on the stack, the stack pointer points to. this is the top of-  ; the stack.-  ; nice getelementptr FAQ: http://llvm.org/docs/GetElementPtr.html-  ;                     value of pointer type,  index,    field-  %top = getelementptr [1000 x i8*]* @stack,   i8 0,     i64 %sp--  ; the contents of memory are updated to contain %str_ptr at the location-  ; specified by the %addr operand-  store i8* %str_ptr, i8** %top--  ; increase stack pointer to point to new free, top of stack-  %newsp = add i64 %sp, 1-  store i64 %newsp, i64* @sp--  ret void-}--; pops element from stack and converts in integer-; returns the element, in case of error undefined-define i64 @pop_int(){-  ; pop-  %top = call i8* @pop()--  ; convert to int, check for error-  %top_int0 = call i32 @atol(i8* %top)-  %top_int1 = sext i32 %top_int0 to i64--  ; return-  ret i64 %top_int1-}--define void @push_float(double %top_float)-{-  ; allocate memory to store string in-  ; TODO: Make sure this is free()'d at _some_ point during-  ;       program execution.-  %buffer_addr = call i8* @malloc(i16 128)-  %to_str_ptr = getelementptr [3 x i8]* @float_to_str, i64 0, i64 0--  ; convert to string-  call i32(i8*, ...)* @snprintf(-          i8* %buffer_addr, i16 128, i8* %to_str_ptr, double %top_float)--  ; push on stack-  call void(i8*)* @push(i8* %buffer_addr)--  ret void-}--define void @push_int(i64 %top_int)-{-  ; allocate memory to store string in-  ; TODO: Make sure this is free()'d at _some_ point during-  ;       program execution.-  %buffer_addr = call i8* @malloc(i16 128)-  %to_str_ptr = getelementptr [3 x i8]* @int_to_str, i64 0, i64 0--  ; convert to string-  call i32(i8*, ...)* @snprintf(-          i8* %buffer_addr, i16 128, i8* %to_str_ptr, i64 %top_int)--  ; push on stack-  call void(i8*)* @push(i8* %buffer_addr)--  ret void-}--define i32 @mult() {-  ; return value of this function-  %func_result = alloca i32, align 4--  ; allocate memory on stack to hold our structures that contains the type-  ; of stack element and its casted value-  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8--  ; get top of stack-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get second top of stack-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--;##############################################################################-;                        integer multiplication-;##############################################################################--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %add_int, label %type_check_a_float--add_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64*-  %ival_a = load i64* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64*-  %ival_b = load i64* %ival_b_cast, align 4--  ; add the two integers and store result on the stack-  %ires = mul i64 %ival_a, %ival_b-  call void(i64)* @push_int(i64 %ires)-  br label %exit_with_success--;##############################################################################-;                        floating point multiplication-;##############################################################################--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %mult_float, label %exit_with_invalid_type--mult_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4-  %fval_a_d = fpext float %fval_a to double--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4-  %fval_b_d = fpext float %fval_b to double--  ; sub the two floats and store result on the stack-  %fres= fmul double %fval_a_d, %fval_b_d-  call void(double)* @push_float(double %fres)-  br label %exit_with_success--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result-}--define i32 @rem() {-  ; return value of this function-  %func_result = alloca i32, align 4--  ; allocate memory on stack to hold our structures that contains the type-  ; of stack element and its casted value-  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8--  ; get top of stack-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get second top of stack-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--;##############################################################################-;                        integer remainder-;##############################################################################--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %rem_int, label %type_check_a_float--rem_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32*-  %ival_a = load i32* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32*-  %ival_b = load i32* %ival_b_cast, align 4--  ; add the two integers and store result on the stack-  %ires = srem i32 %ival_a, %ival_b-  %lres = sext i32 %ires to i64-  call void(i64)* @push_int(i64 %lres)-  br label %exit_with_success--;##############################################################################-;                        floating point remainder-;##############################################################################--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %rem_float, label %exit_with_invalid_type--rem_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4-  %fval_a_d = fpext float %fval_a to double--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4-  %fval_b_d = fpext float %fval_b to double--  ; sub the two floats and store result on the stack-  %fres= frem double %fval_a_d, %fval_b_d-  call void(double)* @push_float(double %fres)-  br label %exit_with_success--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result-}--define i32 @sub() {-  ; return value of this function-  %func_result = alloca i32, align 4--  ; allocate memory on stack to hold our structures that contains the type-  ; of stack element and its casted value-  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8--  ; get top of stack-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get second top of stack-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--;##############################################################################-;                        integer subtraction-;##############################################################################--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %sub_int, label %type_check_a_float--sub_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64*-  %ival_a = load i64* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64*-  %ival_b = load i64* %ival_b_cast, align 4--  ; add the two integers and store result on the stack-  %ires = sub i64 %ival_a, %ival_b-  call void(i64)* @push_int(i64 %ires)-  br label %exit_with_success--;##############################################################################-;                        floating point subtraction-;##############################################################################--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %sub_float, label %exit_with_invalid_type--sub_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4-  %fval_a_d = fpext float %fval_a to double--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4-  %fval_b_d = fpext float %fval_b to double--  ; sub the two floats and store result on the stack-  %fres= fsub double %fval_a_d, %fval_b_d-  call void(double)* @push_float(double %fres)-  br label %exit_with_success--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result-}--define i32 @add() {-  ; return value of this function-  %func_result = alloca i32, align 4--  ; allocate memory on stack to hold our structures that contains the type-  ; of stack element and its casted value-  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8--  ; get top of stack-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get second top of stack-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--;##############################################################################-;                        integer addition-;##############################################################################--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4 -  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %add_int, label %type_check_a_float--add_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64*-  %ival_a = load i64* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64*-  %ival_b = load i64* %ival_b_cast, align 4--  ; add the two integers and store result on the stack-  %ires = add i64 %ival_a, %ival_b-  call void(i64)* @push_int(i64 %ires)-  br label %exit_with_success--;##############################################################################-;                        floating point addition-;##############################################################################--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %add_float, label %exit_with_invalid_type--add_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4-  %fval_a_d = fpext float %fval_a to double--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4-  %fval_b_d = fpext float %fval_b to double--  ; add the two floats and store result on the stack-  %fres= fadd double %fval_a_d, %fval_b_d-  call void(double)* @push_float(double %fres)-  br label %exit_with_success--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result-}--define void @sub_int() {-  ; get top of stack-  %top_1   = call i64()* @pop_int()--  ; get second top of stack-  %top_2   = call i64()* @pop_int()--  ; sub the two values-  %res = sub i64 %top_1, %top_2--  ; store result on stack-  call void(i64)* @push_int(i64 %res)--  ret void-}--define i32 @div() {-  ; return value of this function-  %func_result = alloca i32, align 4--  ; allocate memory on stack to hold our structures that contains the type-  ; of stack element and its casted value-  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8--  ; get top of stack-  call void @underflow_assert() -  %number_a = call i8* @pop()--  ; get second top of stack-  call void @underflow_assert() -  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--;##############################################################################-;                        integer division-;##############################################################################--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %div_int, label %type_check_a_float--div_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32*-  %ival_a = load i32* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32*-  %ival_b = load i32* %ival_b_cast, align 4--  ; prevent division by zero-  %div_by_zero = icmp eq i32 %ival_b, 0-  br i1 %div_by_zero, label %exit_with_zero, label %div_int_ok--div_int_ok:-  ; divide the two integers and store result on the stack-  %ires = sdiv i32 %ival_a, %ival_b-  %lres = sext i32 %ires to i64--  call void(i64)* @push_int(i64 %lres)-  br label %exit_with_success--;##############################################################################-;                        floating point division-;##############################################################################--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %div_float, label %exit_with_invalid_type--div_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4-  %fval_a_d = fpext float %fval_a to double--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4--  ; prevent division by zero-  %div_by_zero_f = fcmp oeq float %fval_b, 0.0-  br i1 %div_by_zero_f, label %exit_with_zero, label %div_float_ok--div_float_ok:-  ; divide the two floats and store result on the stack-  %fval_b_d = fpext float %fval_b to double-  %fres= fdiv double %fval_a_d, %fval_b_d-  call void(double)* @push_float(double %fres)-  br label %exit_with_success--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit_with_zero: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [18 x i8]* @err_zero, i64 0, i64 0))-  br label %exit_with_failure--exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result-}----@main.number_a = private unnamed_addr constant [4 x i8] c"-57\00"-@main.number_b  = private unnamed_addr constant [4 x i8] c"-58\00"--define i32 @main_div() {-  ; push two numbers on the stack-  %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0   -  %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0   --  call void(i8*)* @push(i8* %number0)-  call void(i8*)* @push(i8* %number1)--  call i32 @div()-  %result = call i8* @pop()-  call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]*-              @popped, i32 0, i32 0), i8* %result)--  ret i32 0-}--define i32 @main_equal() {-  ; push two numbers on the stack-  %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0   -  %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0   --  call void(i8*)* @push(i8* %number0)-  call void(i8*)* @push(i8* %number1)--  call i32 @equal()-  %result = call i8* @pop()-  call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]*-              @popped, i32 0, i32 0), i8* %result)--  ret i32 0-}---define i8* @peek() {-  %sp   = load i64* @sp-  %top_of_stack = sub i64 %sp, 1-  %addr = getelementptr [1000 x i8*]* @stack, i8 0, i64 %top_of_stack-  %val = load i8** %addr-  ret i8* %val-}--define i8* @pop() {-  %val = call i8*()* @peek()-  %sp = load i64* @sp-  %top_of_stack = sub i64 %sp, 1-  store i64 %top_of_stack, i64* @sp-  ret i8* %val-}--; TODO: free alloated space of input strings-define void @strapp() {-entry:-  %str2 = call i8*()* @pop()-  %str1 = call i8*()* @pop()--  ; compute length of input strings (TODO: maybe isolate strlen function for this purpose)-  call void(i8*)* @push(i8* %str1)-  call void()* @strlen()-  %len_str1 = call i64()* @pop_int()-  call void(i8*)* @push(i8* %str2)-  call void()* @strlen()-  %len_str2 = call i64()* @pop_int()--  ; allocate space for result string-  %len_result_1 = add i64 %len_str1, %len_str2-  %len_result_2 = add i64 %len_result_1, 1-  %len_result_3 = trunc i64 %len_result_2 to i16-  %result = call i8* @malloc(i16 %len_result_3)--  ; copy first string-  br label %loop1-loop1:-  %i = phi i64 [0, %entry], [ %next_i, %loop1 ]-  %next_i = add i64 %i, 1-  %addr = getelementptr i8* %str1, i64 %i-  %c = load i8* %addr-  %result_addr = getelementptr i8* %result, i64 %i-  store i8 %c, i8* %result_addr-  %cond = icmp eq i8 %c, 0-  br i1 %cond, label %finished, label %loop1-finished:-  ; copy second string-  br label %loop2-loop2:-  %j = phi i64 [0, %finished], [ %next_j, %loop2 ]-  %next_j = add i64 %j, 1-  %addr2 = getelementptr i8* %str2, i64 %j-  %c2 = load i8* %addr2-  %k = add i64 %j, %len_str1-  %result_addr2 = getelementptr i8* %result, i64 %k-  store i8 %c2, i8* %result_addr2-  %cond2 = icmp eq i8 %c2, 0-  br i1 %cond2, label %finished2, label %loop2-finished2:-  call void(i8*)* @push(i8* %result)-  ret void-}--define void @strlen() {-entry:-  %str = call i8*()* @pop()-  br label %loop-loop:-  %i = phi i64 [1, %entry ], [ %next_i, %loop ]-  %next_i = add i64 %i, 1-  %addr = getelementptr i8* %str, i64 %i-  %c = load i8* %addr-  %cond = icmp eq i8 %c, 0-  br i1 %cond, label %finished, label %loop-finished:-  call void(i64)* @push_int(i64 %i)-  ret void-}--define void @streq() {-entry:-  %str1 = call i8*()* @pop()-  %str2 = call i8*()* @pop()-  br label %loop-loop:-  ; the phi instruction says that coming from the 'entry' label i is 1-  ; otherwise (coming from 'cont') i will be 'next_i'-  %i = phi i64 [ 1, %entry ], [ %next_i, %cont ]--  ; the the actual character-  %addr1 = getelementptr i8* %str1, i64 %i-  %addr2 = getelementptr i8* %str2, i64 %i-  %c1 = load i8* %addr1-  %c2 = load i8* %addr2--  ; if equal, jump to next character otherwise jump to 'fail' -  %cond = icmp eq i8 %c1, %c2-  br i1 %cond, label %cont, label %fail--cont:-  %next_i = add i64 %i, 1-  %cond2 = icmp eq i8 %c1, 0-  br i1 %cond2, label %success, label %loop-success:-  %t = getelementptr [2 x i8]* @true, i64 0, i64 0-  call void(i8*)* @push(i8* %t)-  ret void-fail:-  %f = getelementptr [2 x i8]* @false, i64 0, i64 0-  call void(i8*)* @push(i8* %f)-  ret void-}--define i32 @finish(){-  ret i32 0-}--;##############################################################################-;                                 equal-;##############################################################################--define i32 @equal(){-  ; return value of this function-  %func_result = alloca i32, align 4--  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8- -  ; get top-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get top-1-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %cmp_int, label %type_check_a_float--cmp_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32*-  %ival_a = load i32* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32*-  %ival_b = load i32* %ival_b_cast, align 4--  ; the actual comparison-  %equal_int = icmp eq i32 %ival_a, %ival_b -  br i1 %equal_int, label %exit_with_true, label %exit_with_false--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type--cmp_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4--  ; prevent division by zero-  %equal_float = fcmp oeq float %fval_a, %fval_b-  br i1 %equal_float, label %exit_with_true, label %exit_with_false---exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_true: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [2 x i8]* @true, i64 0, i64 0))-  br label %exit_with_success--exit_with_false: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [2 x i8]* @false, i64 0, i64 0))-  br label %exit_with_success--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result--}--;##############################################################################-;                                 greater-;##############################################################################--define i32 @greater(){-  ; return value of this function-  %func_result = alloca i32, align 4--  %new_elem_a = alloca %struct.stack_elem, align 8-  %new_elem_b = alloca %struct.stack_elem, align 8- -  ; get top-  call void @underflow_assert()-  %number_a = call i8* @pop()--  ; get top-1-  call void @underflow_assert()-  %number_b = call i8* @pop()--  ; get type of number_a-  %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a)-  %is_zero_a = icmp slt i32 %ret_a, 0-  br i1 %is_zero_a, label %exit_with_failure, label %get_type_b--get_type_b:-  ; get type of number_b-  %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b)-  %is_zero_b = icmp slt i32 %ret_b, 0-  br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int--type_check_a_int:-  ; first, load the new_elem_a.type element. check whether it is 1 (aka INT).-  %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %type_a = load i32* %type_a_ptr, align 4-  %is_int_a = icmp eq i32 %type_a, 1-  br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float--type_check_b_int:-  ; first, load the new_elem_b.type element. check whether it is 1 (aka INT).-  %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %type_b = load i32* %type_b_ptr, align 4-  %is_int_b = icmp eq i32 %type_b, 1-  br i1 %is_int_b, label %cmp_int, label %type_check_a_float--cmp_int:-  ; get new_elem_a.ival that contains the casted integer value-  %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32*-  %ival_a = load i32* %ival_a_cast, align 4--  ; get new_elem_b.ival that contains the casted integer value-  %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32*-  %ival_b = load i32* %ival_b_cast, align 4--  ; the actual comparison-  %greater_int = icmp sgt i32 %ival_a, %ival_b -  br i1 %greater_int, label %exit_with_true, label %exit_with_false--type_check_a_float:-  %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0-  %ftype_a = load i32* %ftype_a_ptr, align 4-  %is_float_a = icmp eq i32 %ftype_a, 2 -  br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type--type_check_b_float:-  %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0-  %ftype_b = load i32* %ftype_b_ptr, align 4-  %is_float_b = icmp eq i32 %ftype_b, 2-  br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type--cmp_float:-  ; get new_elem_a.fval that contains the float value-  %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1-  %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float*-  %fval_a = load float* %fval_a_cast, align 4--  ; get new_elem_b.fval that contains the float value-  %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1-  %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float*-  %fval_b = load float* %fval_b_cast, align 4--  ; prevent division by zero-  %greater_float = fcmp ogt float %fval_a, %fval_b-  br i1 %greater_float, label %exit_with_true, label %exit_with_false---exit_with_invalid_type: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [14 x i8]* @err_type, i64 0, i64 0))-  br label %exit_with_failure--exit_with_true: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [2 x i8]* @true, i64 0, i64 0))-  br label %exit_with_success--exit_with_false: -  call void(i8*)* @push(i8* getelementptr inbounds(-                                          [2 x i8]* @false, i64 0, i64 0))-  br label %exit_with_success--exit_with_failure:-  store i32 -1, i32* %func_result-  br label %exit--exit_with_success:-  store i32 0, i32* %func_result-  br label %exit--exit:-  %result = load i32* %func_result-  ret i32 %result--}---; Popping a pointer from the stack into a variable-define void @pop_into(i8** %var_ptr) {-  call void @underflow_assert()-  %val_ptr = call i8* @pop()-  store i8* %val_ptr, i8** %var_ptr-  ret void-}--; Pushing a pointer from a variable onto the stack-define void @push_from(i8** %var_ptr) {-  %val = load i8** %var_ptr-  call void @push (i8* %val)-  ret void-}--; Function Attrs: nounwind uwtable-; Takes a string, determines the type it is representing and returns the-; corresponding stack element structure.-define i32 @get_stack_elem(i8* %string, %struct.stack_elem* %elem) #0 {-  %1 = alloca i32, align 4-  %2 = alloca i8*, align 8-  %3 = alloca %struct.stack_elem*, align 8-  %pEnd = alloca i8*, align 8-  %new_long = alloca i64, align 8-  %new_float = alloca float, align 4-  store i8* %string, i8** %2, align 8-  store %struct.stack_elem* %elem, %struct.stack_elem** %3, align 8-  %4 = load i8** %2, align 8-  %5 = call i64 @strtol(i8* %4, i8** %pEnd, i32 10) #2-  store i64 %5, i64* %new_long, align 8-  %6 = load i8** %pEnd, align 8-  %7 = load i8* %6, align 1-  %8 = sext i8 %7 to i32-  %9 = icmp eq i32 %8, 0-  br i1 %9, label %10, label %18--; <label>:10                                      ; preds = %0-  %11 = load %struct.stack_elem** %3, align 8-  %12 = getelementptr inbounds %struct.stack_elem* %11, i32 0, i32 0-  store i32 1, i32* %12, align 4-  %13 = load i64* %new_long, align 8-  %14 = trunc i64 %13 to i32-  %15 = load %struct.stack_elem** %3, align 8-  %16 = getelementptr inbounds %struct.stack_elem* %15, i32 0, i32 1-  %17 = bitcast %union.anon* %16 to i32*-  store i32 %14, i32* %17, align 4-  store i32 0, i32* %1-  br label %39--; <label>:18                                      ; preds = %0-  %19 = load i8** %2, align 8-  %20 = call float @strtof(i8* %19, i8** %pEnd) #2-  store float %20, float* %new_float, align 4-  %21 = load i8** %pEnd, align 8-  %22 = load i8* %21, align 1-  %23 = sext i8 %22 to i32-  %24 = icmp eq i32 %23, 0-  br i1 %24, label %25, label %32--; <label>:25                                      ; preds = %18-  %26 = load %struct.stack_elem** %3, align 8-  %27 = getelementptr inbounds %struct.stack_elem* %26, i32 0, i32 0-  store i32 2, i32* %27, align 4-  %28 = load float* %new_float, align 4-  %29 = load %struct.stack_elem** %3, align 8-  %30 = getelementptr inbounds %struct.stack_elem* %29, i32 0, i32 1-  %31 = bitcast %union.anon* %30 to float*-  store float %28, float* %31, align 4-  store i32 0, i32* %1-  br label %39--; <label>:32                                      ; preds = %18-  %33 = load %struct.stack_elem** %3, align 8-  %34 = getelementptr inbounds %struct.stack_elem* %33, i32 0, i32 0-  store i32 3, i32* %34, align 4-  %35 = load i8** %2, align 8-  %36 = load %struct.stack_elem** %3, align 8-  %37 = getelementptr inbounds %struct.stack_elem* %36, i32 0, i32 1-  %38 = bitcast %union.anon* %37 to i8**-  store i8* %35, i8** %38, align 8-  store i32 0, i32* %1-  br label %39--; <label>:39                                      ; preds = %32, %25, %10-  %40 = load i32* %1-  ret i32 %40-}--@number2 = private unnamed_addr constant [2 x i8] c"5\00"-@number3 = private unnamed_addr constant [2 x i8] c"2\00"--define i32 @main_() {- %pushingptr = getelementptr [14 x i8]* @pushing, i64 0, i64 0- %poppedptr = getelementptr [13 x i8]* @popped, i64 0, i64 0-- call void @eof_check()- %i1 = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %i1)-- call void @input()- %i0 = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %i0)-- call void @input()- %i2 = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %i2)-- ; push two numbers on the stack- %number2 = getelementptr [2 x i8]* @number2, i64 0, i64 0- %number3 = getelementptr [2 x i8]* @number3, i64 0, i64 0-- call i32(i8*, ...)* @printf(i8* %pushingptr, i8* %number2)- call void(i8*)* @push(i8* %number2)-- call i32(i8*, ...)* @printf(i8* %pushingptr, i8* %number3)- call void(i8*)* @push(i8* %number3)-- call void @underflow_check()- %size0 = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %size0)-- call void @sub_int()- %sum  = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %sum)-- call void @underflow_check()- %size1 = call i8*()* @pop()- call i32(i8*, ...)* @printf(i8* %poppedptr, i8* %size1)-- ret i32 0+; Module      : LLVM backend - stack helper functions (and some misc. functions)+; Description : Contains helper functions for working with the stack and also+;               some functions which have not yet been split out into their own modules.+; Maintainers : Tilman Blumenbach, Sascha Zinke, Maximilian Claus, Tudor Soroceanu,+;               Philipp Borgers, Lyudmila Vaseva, Marcus Hoffmann, Michal Ajchman+; License     : MIT+;+; Beware: Many of these functions directly crash (in Rail terms: properly exit) the program.+++; Types++; See linked_stack.ll for the definition.+%stack_element = type opaque++; Misnamed struct returned by get_stack_elem() (which, unfortunately,+; is also misnamed). This is not the data type used for real stack elements,+; but more like a container used to store conversion results (string to numerical+; value).+;+; C definition was as follows:+;+;  typedef enum {INT = 1, FLOAT = 2, STRING = 3} elem_type;+;  struct stack_elem {+;      elem_type type;+;      union {+;          int ival;+;          float fval;+;          char *sval;+;      };+;  };+%struct.stack_elem = type { i32, %union.anon }+%union.anon = type { i8* }++; struct for the symbol table+%struct.table = type {i8*, %stack_element*, %struct.table*}++; Global variables+@lookahead = global i32 -1            ; Current lookahead for input from stdin,+                                      ; -1 means no lookahead done yet.++; Constants+@err_numeric = unnamed_addr constant [56 x i8] c"Failed to check whether stack elem is of type numeric!\0A\00"+@crash_cust_str_fmt = private unnamed_addr constant [24 x i8] c"Crash: Custom error: %s\00"+@err_stack_underflow = private unnamed_addr constant [18 x i8] c"Stack underflow!\0A\00"+@err_zero = unnamed_addr constant [18 x i8] c"Division by zero!\00"+@printf_str_fmt = private unnamed_addr constant [3 x i8] c"%s\00"+@err_oom = unnamed_addr constant [15 x i8] c"Out of memory!\00"+@err_type = unnamed_addr constant [14 x i8] c"Invalid type!\00"+@to_str  = private unnamed_addr constant [3 x i8] c"%i\00"+@err_eof = unnamed_addr constant [9 x i8] c"At EOF!\0A\00"+@false = unnamed_addr constant [2 x i8] c"0\00"+@true = unnamed_addr constant [2 x i8] c"1\00"+@write_mode = global [2 x i8] c"w\00"+@type_string = external global [7 x i8]+@type_lambda = external global  [7 x i8]+@type_list = external global [5 x i8]+@type_nil = external global [4 x i8]++; External declarations+%FILE = type opaque++@stderr = global %FILE* undef++declare i64 @strtol(i8*, i8**, i32 )+declare signext i32 @printf(i8*, ...)+declare %FILE* @fdopen(i32, i8*)+declare signext i32 @fprintf(%FILE*, i8*, ...)+declare float @strtof(i8*, i8**)+declare signext i32 @getchar()+declare i8* @calloc(i16 zeroext, i16 zeroext)+declare i8* @strdup(i8*)+declare void @exit(i32 signext)++declare %stack_element* @pop_struct()+declare void @push_struct(%stack_element*)+declare i8* @stack_element_get_data(%stack_element* %element)+declare i64 @pop_int()+declare i8* @pop_string()+declare void @push_int(i64)+declare %stack_element* @push_string_cpy(i8*)+declare %stack_element* @push_string_ptr(i8*)+declare i32 @stack_element_get_refcount(%stack_element*)+declare i8 @stack_element_get_type(%stack_element*)+declare %stack_element* @stack_element_new(i8, i8*, %stack_element*)+declare i64 @stack_get_size()+declare void @stack_element_ref(%stack_element* %element)+declare void @stack_element_unref(%stack_element* %element)+declare i8* @malloc(i64)++; Debugging stuff+@pushing = unnamed_addr constant [14 x i8] c"Pushing [%s]\0A\00"+@popped  = unnamed_addr constant [13 x i8] c"Popped [%s]\0a\00"+@msg = unnamed_addr constant [5 x i8] c"msg\0a\00"+@no_element = private unnamed_addr constant [18 x i8] c"No such Element!\0A\00"++@int_to_str = unnamed_addr constant [3 x i8] c"%i\00"+@float_to_str = unnamed_addr constant [3 x i8] c"%f\00"++@.str = private unnamed_addr constant [33 x i8] c"call int add with a=%i and b=%i\0A\00", align 1+@.str1 = private unnamed_addr constant [35 x i8] c"call float add with a=%f and b=%f\0A\00", align 1+@.str2 = private unnamed_addr constant [15 x i8] c"failed to add\0A\00", align 1++++; Function definitions++; Push the stack size onto the stack+define void @underflow_check() {+  %stack_size = call i64 @stack_get_size()+  call void @push_int(i64 %stack_size)+  ret void+}++; Exit the program if stack is empty (prints error to stderr).+define void @underflow_assert() {+  %stack_size = call i64 @stack_get_size()+  %stack_empty = icmp eq i64 %stack_size, 0+  br i1 %stack_empty, label %uas_crash, label %uas_okay++uas_crash:+  %err = getelementptr [18 x i8]* @err_stack_underflow, i8 0, i8 0+  %stderr = load %FILE** @stderr+  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %err)+  call void @exit(i32 1)++  ret void++uas_okay:+  ret void+}++; pushes 'string' or 'nil' or 'list' or 'lambda' on stack, depending on the type+; of the top stack element.+define void @type(){+  %element = call %stack_element* @pop_struct()+  %actual_type = call i8 @stack_element_get_type(%stack_element* %element)+  br label %check_string++check_string:+  %is_string = icmp eq i8 %actual_type, 0+  br i1 %is_string, label %return_string, label %check_list++return_string:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                         [7 x i8]* @type_string, i64 0, i64 0))+  br label %exit++check_list:+  %is_list = icmp eq i8 %actual_type, 1+  br i1 %is_list, label %check_nil, label %check_lambda++check_nil:+  %dataPtr = call i8* @stack_element_get_data(%stack_element* %element)+  %is_nil = icmp eq i8* %dataPtr, null +  br i1 %is_nil, label %return_nil, label %return_list++check_lambda:+  %is_lambda = icmp eq i8 %actual_type, 2+  br i1 %is_lambda, label %return_lambda, label %return_error++return_nil:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                         [4 x i8]* @type_nil, i64 0, i64 0))+  br label %exit++return_list:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                         [5 x i8]* @type_list, i64 0, i64 0))+  br label %exit++return_lambda:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                         [7 x i8]* @type_lambda, i64 0, i64 0))+  br label %exit++return_error:+  call %stack_element* @push_string_cpy(i8* getelementptr inbounds(+                                          [14 x i8]* @err_type, i64 0, i64 0))+  call void @crash(i1 0)+  br label %exit++exit:+  call void @stack_element_unref(%stack_element* %element)++  ret void+}++; Pop stack and print result string+define void @print() {+  call void @underflow_assert()++  %fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0+  %elem = call %stack_element*()* @pop_struct()+  %val = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %elem)+  call i32(i8*, ...)* @printf(i8* %fmt, i8* %val)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem)++  ret void+}++; Pop stack, print result string to stderr and exit the program.+define void @crash(i1 %is_custom_error) {+  call void @underflow_assert()+  br i1 %is_custom_error, label %custom_error, label %raw_error++custom_error:+  %cust_fmt = getelementptr [24 x i8]* @crash_cust_str_fmt, i8 0, i8 0+  br label %end++raw_error:+  %raw_fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0+  br label %end++end:+  %fmt = phi i8* [%raw_fmt, %raw_error], [%cust_fmt, %custom_error]+  %val = call i8* @pop_string()+  %stderr = load %FILE** @stderr+  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %fmt, i8* %val)+  ; Now, crash!+  call void @exit(i32 1)++  ret void+}++; Get a byte of input from stdin and push it.+; Crashes the program on errors.+define void @input() {+  %read = call i32 @input_get()+  %err = icmp slt i32 %read, 0+  br i1 %err, label %error, label %push++error:+  %at_eof = getelementptr [9 x i8]* @err_eof, i64 0, i64 0+  call %stack_element* @push_string_cpy(i8* %at_eof)+  call void @crash(i1 0)+  ret void++push:+  %byte = trunc i32 %read to i8+  %buffer_addr = call i8* @xcalloc(i16 1, i16 2)+  store i8 %byte, i8* %buffer_addr+  call %stack_element* @push_string_ptr(i8* %buffer_addr)++  ret void+}++; Get a byte of input from stdin. Returns < 0 on error.+; This can be used together with input_peek().+define i32 @input_get() {+  %lookahead = load i32* @lookahead+  %need_read = icmp slt i32 %lookahead, 0+  br i1 %need_read, label %ig_read, label %ig_lookahead++ig_lookahead:+  store i32 -1, i32* @lookahead+  ret i32 %lookahead++ig_read:+  %read = call i32 @getchar()+  ret i32 %read+}++; Peek a byte of input from stdin. Returns < 0 on error.+; Successive calls to this function without interspersed calls+; to input_read() return the same value.+define i32 @input_peek() {+  %read = call i32 @input_get()+  store i32 %read, i32* @lookahead+  ret i32 %read+}++; If stdin is at EOF, push 1, else 0.+define void @eof_check() {+  %peek = call i32 @input_peek()+  %is_eof = icmp slt i32 %peek, 0+  br i1 %is_eof, label %at_eof, label %not_at_eof++at_eof:+  %true = getelementptr [2 x i8]* @true, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %true)+  ret void++not_at_eof:+  %false = getelementptr [2 x i8]* @false, i8 0, i8 0+  call %stack_element* @push_string_cpy(i8* %false)++  ret void+}+++define i32 @finish(){+  ret i32 0+}++; Popping a pointer from the stack into a variable+define void @pop_into(%struct.table* %t, i8* %name){+  call void @underflow_assert()+  +  %n_ptr = getelementptr inbounds %struct.table* %t, i32 0, i32 0+  %name_t = load i8** %n_ptr, align 8+  %is_null = icmp eq i8* %name_t, null+  br i1 %is_null, label %insert, label %search+insert:+  ; store name+  store i8* %name, i8** %n_ptr, align 8+  +  ; pop value from stack and store value+  %value = call %stack_element*()* @pop_struct()+  call void @stack_element_ref(%stack_element* %value)+  %v_ptr = getelementptr inbounds %struct.table* %t, i32 0, i32 1+  store %stack_element* %value, %stack_element** %v_ptr, align 8+  +  ; create new element and append to table+  %new_elem_alloc = call i8* @malloc(i64 24)+  %new_elem = bitcast i8* %new_elem_alloc to %struct.table*+  ; initialise new element with null+  call void @initialise(%struct.table* %new_elem)++  %next_ptr = getelementptr inbounds %struct.table* %t, i32 0, i32 2+  store %struct.table* %new_elem, %struct.table** %next_ptr, align 8+  +  br label %end++search:+  %is_equal = icmp eq i8* %name_t, %name+  br i1 %is_equal, label %insert2, label %search_further++insert2:+  %value2 = call %stack_element*()* @pop_struct()+  call void @stack_element_ref(%stack_element* %value2)+  %v_ptr_found = getelementptr inbounds %struct.table* %t, i32 0, i32 1+  %old_value = load %stack_element** %v_ptr_found, align 8+  call void @stack_element_unref(%stack_element* %old_value)+  store %stack_element* %value2, %stack_element** %v_ptr_found, align 8+  +  br label %end++search_further:+  %next_ptr_recursive = getelementptr inbounds %struct.table* %t, i32 0, i32 2+  %next_ptr_recursive2 = load %struct.table** %next_ptr_recursive, align 8+  call void @pop_into(%struct.table* %next_ptr_recursive2, i8* %name) +  br label %end++end:+  ret void+}++; Pushing a pointer from a variable onto the stack+define void @push_from(%struct.table* %t, i8* %name){+  %n_ptr = getelementptr inbounds %struct.table* %t, i64 0, i32 0+  %name_t = load i8** %n_ptr++  %is_null = icmp eq i8* %name_t, null+  br i1 %is_null, label %no_such_elem, label %search+no_such_elem:+  %no_elem = getelementptr [18 x i8]* @no_element, i64 0, i64 0+  call i32(i8*, ...)* @printf(i8* %no_elem)+  br label %end++search:+  %is_equal = icmp eq i8* %name_t, %name+  br i1 %is_equal, label %push_onto_stack, label %search_further++push_onto_stack:+  %v_ptr_found = getelementptr inbounds %struct.table* %t, i64 0, i32 1+  %value_to_push = load %stack_element** %v_ptr_found+  call void @stack_element_ref(%stack_element* %value_to_push)+  call void @push_struct(%stack_element* %value_to_push)++  br label %end++search_further:+  %next_ptr_recursive = getelementptr inbounds %struct.table* %t, i64 0, i32 2+  %next_ptr_recursive2 = load %struct.table** %next_ptr_recursive+  call void @push_from(%struct.table* %next_ptr_recursive2, i8* %name) +  br label %end++end:+  ret void+}++; Copy Function+; Takes two symbol tables and copies the whole content from the first to the second+; This is especially usefull for the lambda funtion+define void @copy_symbol_table(%struct.table* %old, %struct.table* %new){+  ; get pointers to the name field and store in the new table+  %n_ptr_old = getelementptr inbounds %struct.table* %old, i64 0, i32 0+  %n_ptr_new = getelementptr inbounds %struct.table* %new, i64 0, i32 0+  %name = load i8** %n_ptr_old+  store i8* %name, i8** %n_ptr_new++  %is_null = icmp eq i8* %name, null+  br i1 %is_null, label %end, label %next++next:+  ; get pointers to the value field and copy it +  %v_ptr_old = getelementptr inbounds %struct.table* %old, i64 0, i32 1+  %v_ptr_new = getelementptr inbounds %struct.table* %new, i64 0, i32 1+  %value = load %stack_element** %v_ptr_old+  store %stack_element* %value, %stack_element** %v_ptr_new+  +  ; initialise a new element and append it to the new table+  %new_elem_alloc = call i8* @malloc(i64 24)+  %new_elem = bitcast i8* %new_elem_alloc to %struct.table*+  call void @initialise(%struct.table* %new_elem)+  +  %next_ptr_old = getelementptr inbounds %struct.table* %old, i64 0, i32 2  +  %next_ptr_new = getelementptr inbounds %struct.table* %new, i64 0, i32 2  +  store %struct.table* %new_elem, %struct.table** %next_ptr_new+  +  ;recursive call of copy function+  %next_ptr_old2 = load %struct.table** %next_ptr_old, align 8+  %next_ptr_new2 = load %struct.table** %next_ptr_new, align 8+  call void @copy_symbol_table(%struct.table* %next_ptr_old2, %struct.table* %next_ptr_new2)+  br label %end+end:+  ret void+}++; initialise the symbol table with the first element = null+define void @initialise(%struct.table* %t){+  %1 = getelementptr inbounds %struct.table* %t, i32 0, i32 0+  store i8* null, i8** %1, align 8++  ret void+}++; Function Attrs: nounwind uwtable+; Takes a string, determines the type it is representing and returns the+; corresponding stack element structure. Not that this is NOT an actual+; stack element structure, but more like a container used to store the conversion+; results (string to numerical value).+define i32 @get_stack_elem(i8* %string, %struct.stack_elem* %elem) #0 {+  %1 = alloca i32, align 4+  %2 = alloca i8*, align 8+  %3 = alloca %struct.stack_elem*, align 8+  %pEnd = alloca i8*, align 8+  %new_long = alloca i64, align 8+  %new_float = alloca float, align 4+  store i8* %string, i8** %2, align 8+  store %struct.stack_elem* %elem, %struct.stack_elem** %3, align 8+  %4 = load i8** %2, align 8+  %5 = call i64 @strtol(i8* %4, i8** %pEnd, i32 10) #2+  store i64 %5, i64* %new_long, align 8+  %6 = load i8** %pEnd, align 8+  %7 = load i8* %6, align 1+  %8 = sext i8 %7 to i32+  %9 = icmp eq i32 %8, 0+  br i1 %9, label %10, label %18++; <label>:10                                      ; preds = %0+  %11 = load %struct.stack_elem** %3, align 8+  %12 = getelementptr inbounds %struct.stack_elem* %11, i32 0, i32 0+  store i32 1, i32* %12, align 4+  %13 = load i64* %new_long, align 8+  %14 = trunc i64 %13 to i32+  %15 = load %struct.stack_elem** %3, align 8+  %16 = getelementptr inbounds %struct.stack_elem* %15, i32 0, i32 1+  %17 = bitcast %union.anon* %16 to i32*+  store i32 %14, i32* %17, align 4+  store i32 0, i32* %1+  br label %39++; <label>:18                                      ; preds = %0+  %19 = load i8** %2, align 8+  %20 = call float @strtof(i8* %19, i8** %pEnd) #2+  store float %20, float* %new_float, align 4+  %21 = load i8** %pEnd, align 8+  %22 = load i8* %21, align 1+  %23 = sext i8 %22 to i32+  %24 = icmp eq i32 %23, 0+  br i1 %24, label %25, label %32++; <label>:25                                      ; preds = %18+  %26 = load %struct.stack_elem** %3, align 8+  %27 = getelementptr inbounds %struct.stack_elem* %26, i32 0, i32 0+  store i32 2, i32* %27, align 4+  %28 = load float* %new_float, align 4+  %29 = load %struct.stack_elem** %3, align 8+  %30 = getelementptr inbounds %struct.stack_elem* %29, i32 0, i32 1+  %31 = bitcast %union.anon* %30 to float*+  store float %28, float* %31, align 4+  store i32 0, i32* %1+  br label %39++; <label>:32                                      ; preds = %18+  %33 = load %struct.stack_elem** %3, align 8+  %34 = getelementptr inbounds %struct.stack_elem* %33, i32 0, i32 0+  store i32 3, i32* %34, align 4+  %35 = load i8** %2, align 8+  %36 = load %struct.stack_elem** %3, align 8+  %37 = getelementptr inbounds %struct.stack_elem* %36, i32 0, i32 1+  %38 = bitcast %union.anon* %37 to i8**+  store i8* %35, i8** %38, align 8+  store i32 0, i32* %1+  br label %39++; <label>:39                                      ; preds = %32, %25, %10+  %40 = load i32* %1+  ret i32 %40+}++; "Fatal" version of calloc(3): crash()es the program on errors.+define i8* @xcalloc(i16 zeroext %nmemb, i16 zeroext %size) {+  %mem = call i8* @calloc(i16 %nmemb, i16 %size)+  %is_null = icmp eq i8* %mem, null+  br i1 %is_null, label %bail_out, label %okay++bail_out:+  ; Oopsie, out of memory. Try to bail out politely.+  %oom_str = getelementptr [15 x i8]* @err_oom, i32 0, i32 0+  call %stack_element* @push_string_cpy(i8* %oom_str)+  call void @crash(i1 0)++  ret i8* null++okay:+  ret i8* %mem+}++; "Fatal" version of strdup(3): crash()es the program on errors.+define i8* @xstrdup(i8* %str) {+  %mem = call i8* @strdup(i8* %str)+  %is_null = icmp eq i8* %mem, null+  br i1 %is_null, label %bail_out, label %okay++bail_out:+  ; Oopsie, out of memory. Try to bail out politely.+  %oom_str = getelementptr [15 x i8]* @err_oom, i32 0, i32 0+  call %stack_element* @push_string_cpy(i8* %oom_str)+  call void @crash(i1 0)++  ret i8* null++okay:+  ret i8* %mem+}++;##############################################################################+;                                  init+;##############################################################################+define void @start() {++  %write_mode = getelementptr [2 x i8]* @write_mode, i64 0, i64 0+  %stderr = call %FILE* @fdopen(i32 2, i8* %write_mode)+  store %FILE* %stderr, %FILE** @stderr++  ret void }  ; vim:sw=2 ts=2 et
+ src/RailCompiler/string.ll view
@@ -0,0 +1,191 @@+; Module      : LLVM backend - string functions+; Description : Contains LLVM functions for operations on strings (e. g. concatenation).+; Maintainers : Maximilian Claus+; License     : MIT+;+; These functions are used by our LLVM backend and most of them operate+; directly on the stack -- see stack.ll.++@true = external global i8+@false = external global i8+@.str_err0 = unnamed_addr constant [41 x i8] c"Crash: strcut called with negative index\00"+@.str_err1 = unnamed_addr constant [58 x i8] c"Crash: strcut called with index larger than string length\00"+@strcut_neg_arg_err = global i8* getelementptr inbounds ([41 x i8]* @.str_err0, i64 0, i64 0), align 8+@strcut_too_large_arg_err = global i8* getelementptr inbounds ([58 x i8]* @.str_err1, i64 0, i64 0), align 8++; error handling+%FILE = type opaque+@stderr = external global %FILE*+declare signext i32 @fprintf(%FILE*, i8*, ...)+declare void @exit(i32 signext)++; stack functions+%stack_element = type opaque++declare void @underflow_assert()+declare %stack_element* @push_string_ptr(i8* %str)+declare %stack_element* @push_string_cpy(i8* %str)+declare void @push_int(i64)+declare %stack_element* @pop_struct()+declare void @stack_element_assert_type(%stack_element*, i8)+declare i8* @stack_element_get_data(%stack_element* %element)+declare i64 @stack_element_get_int_data(%stack_element* %element)+declare void @stack_element_unref(%stack_element* %element)++declare i8* @malloc(i16 zeroext) ; void *malloc(size_t) and size_t is 16 bits long (SIZE_MAX)++; TODO: free alloated space of input strings+define void @strapp() {+entry:+  call void @underflow_assert() +  %elem2 = call %stack_element*()* @pop_struct()+  %str2 = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %elem2)+  call void @underflow_assert() +  %elem1 = call %stack_element*()* @pop_struct()+  %str1 = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %elem1)++  ; compute length of input strings+  %len_str1 = call i64(i8*)* @length(i8* %str1)+  %len_str2 = call i64(i8*)* @length(i8* %str2)++  ; allocate space for result string+  %len_result_1 = add i64 %len_str1, %len_str2+  %len_result_2 = add i64 %len_result_1, 1+  %len_result_3 = trunc i64 %len_result_2 to i16+  %result = call i8* @malloc(i16 %len_result_3)++  ; copy first string into result+  br label %loop1+loop1:+  %i = phi i64 [0, %entry], [ %next_i, %loop1 ]+  %next_i = add i64 %i, 1+  %addr = getelementptr i8* %str1, i64 %i+  %c = load i8* %addr+  %result_addr = getelementptr i8* %result, i64 %i+  store i8 %c, i8* %result_addr+  %cond = icmp eq i8 %c, 0+  br i1 %cond, label %finished, label %loop1+finished:+  ; copy second string into result+  br label %loop2+loop2:+  %j = phi i64 [0, %finished], [ %next_j, %loop2 ]+  %next_j = add i64 %j, 1+  %addr2 = getelementptr i8* %str2, i64 %j+  %c2 = load i8* %addr2+  %k = add i64 %j, %len_str1+  %result_addr2 = getelementptr i8* %result, i64 %k+  store i8 %c2, i8* %result_addr2+  %cond2 = icmp eq i8 %c2, 0+  br i1 %cond2, label %finished2, label %loop2+finished2:+  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem2)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem1)+  call %stack_element* @push_string_ptr(i8* %result)+  ret void+}++define i64 @length(i8* %str) {+entry:+  br label %loop+loop:+  %i = phi i64 [0, %entry ], [ %next_i, %loop ]+  %next_i = add i64 %i, 1+  %addr = getelementptr i8* %str, i64 %i+  %c = load i8* %addr+  %cond = icmp eq i8 %c, 0+  br i1 %cond, label %finished, label %loop+finished:+  ret i64 %i+}++define void @strlen() {+entry:  +  ; pop string+  call void @underflow_assert() +  %elem = call %stack_element*()* @pop_struct()+  %str = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %elem)++  ; compute length+  %len = call i64(i8*)* @length(i8* %str)++  ; push length+  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem)+  call void(i64)* @push_int(i64 %len)+  ret void+}++define void @strcut() {+entry:+  call void @underflow_assert()+  %elem2 = call %stack_element*()* @pop_struct()+  %indx = call i64(%stack_element*)* @stack_element_get_int_data(%stack_element* %elem2)++  call void @underflow_assert() +  %elem1 = call %stack_element*()* @pop_struct()+  call void @stack_element_assert_type(%stack_element* %elem1, i8 0)+  %str = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %elem1)++  ; allocate space for result strings+  %len1_1 = add i64 %indx, 1+  %len1 = trunc i64 %len1_1 to i16+  %len_str = call i64(i8*)* @length(i8* %str) +  %len2_1 = sub i64 %len_str, %indx+  %len2_2 = add i64 %len2_1, 1+  %len2 = trunc i64 %len2_2 to i16+  %result1 = call i8* @malloc(i16 %len1)+  %result2 = call i8* @malloc(i16 %len2)++  ; check whether index argument is within bounds+  %stderr = load %FILE** @stderr++  %err0 = icmp slt i64 %indx, 0+  br i1 %err0, label %neg_arg, label %continue_check+neg_arg:+  %err_msg0 = load i8** @strcut_neg_arg_err+  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %err_msg0)+  call void @exit(i32 1)+  ret void+continue_check:+  %err1 = icmp sgt i64 %indx, %len_str+  br i1 %err1, label %too_large_arg, label %loop1+too_large_arg:+  %err_msg1 = load i8** @strcut_too_large_arg_err+  call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %err_msg1)+  call void @exit(i32 1)+  ret void++  ; fill result1 string+loop1:+  %i = phi i64 [0, %continue_check], [ %next_i, %loop1 ]+  %next_i = add i64 %i, 1+  %addr = getelementptr i8* %str, i64 %i+  %c = load i8* %addr+  %result_addr = getelementptr i8* %result1, i64 %i+  store i8 %c, i8* %result_addr+  %cond = icmp eq i64 %i, %indx+  br i1 %cond, label %finished, label %loop1+finished:+  %end_addr = getelementptr i8* %result1, i64 %indx+  store i8 0, i8* %end_addr+  ; fill result2 string+  br label %loop2+loop2:+  %j = phi i64 [0, %finished], [ %next_j, %loop2 ]+  %next_j = add i64 %j, 1+  %k = add i64 %j, %indx+  %addr2 = getelementptr i8* %str, i64 %k+  %c2 = load i8* %addr2+  %result_addr2 = getelementptr i8* %result2, i64 %j+  store i8 %c2, i8* %result_addr2+  %cond2 = icmp eq i8 %c2, 0+  br i1 %cond2, label %finished2, label %loop2+finished2: +  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem2)+  call void(%stack_element*)* @stack_element_unref(%stack_element* %elem1)+  call %stack_element* @push_string_ptr(i8* %result2)+  call %stack_element* @push_string_ptr(i8* %result1)+  ret void+}++; vim:sw=2 ts=2 et
+ src/RailEditor/Editor.hs view
@@ -0,0 +1,23 @@+{- |+Module      :  Editor.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT++Stability   :  experimental++This is the main-module (and entrypoint) for the Editor.+-}+module Main (+               main -- main-function calling the editor+                    -- to be completed with missing required functions+              )+  where++    -- imports --+import qualified MainWindow+    -- functions --++    -- main-function calling the editor+main :: IO ()+main = MainWindow.create
− src/RailEditor/EditorBackend.hs 
@@ -1,279 +0,0 @@-{-# LANGUAGE DeriveDataTypeable#-}-module EditorBackend where--import Data.Typeable (Typeable)-import Data.List.Split (split,keepDelimsL,whenElt,splitWhen)-import Data.Data (Data,toConstr)-import Data.Maybe---- !!!please dont create dependencies to this module without an announcement, because it is still in the creating and refactoring process!!!---- Represents a charakter of a programm with the charakter (Char), his coordinate inside the function relative to the $ charakter and a Bool (for determine in the parsing process, whether the process already visited the field)-data Field = Field HighlightChar Bool deriving (Show,Eq)--- Represents a function, with the name (String) and the Code ([[Field]])-data Function = Function String [[Field]] deriving (Show,Eq)--- Represents a Programm, which is a set of Functions-data Programm = Programm [Function] deriving (Show,Eq)--- Represents the next move of the 'train'-data Move = Allowed (Int,Int) | Forbidden (Int,Int) deriving (Show,Eq)--- Represents the direction of the 'train'-data Direction = North | South | West | East | NorthWest | NorthEast | SouthWest | SouthEast deriving (Show,Eq)--- Define Highlighting Classes for making highlight with an xml-config file possible in a later version (e.g. <MathOp color=#FF0011> ...)-data HighlightChar =  Undefined Char | MathOp Char | StringOp Char | Misc Char | Constant Char | FunctionUse Char | SystemOp Char | VariableOp Char | ListOp Char | Conditional Char | Rail Char | Cross Char | If Char | Mixed Char deriving (Show, Eq, Data, Typeable)----begin: HighlightChar operations-fromHighlightChar :: HighlightChar -> Char-fromHighlightChar (Undefined c) = c-fromHighlightChar (MathOp c) = c-fromHighlightChar (StringOp c) = c-fromHighlightChar (Misc c) = c-fromHighlightChar (Constant c) = c-fromHighlightChar (FunctionUse c) = c-fromHighlightChar (SystemOp c) = c-fromHighlightChar (VariableOp c) = c-fromHighlightChar (ListOp c) = c-fromHighlightChar (Conditional c) = c-fromHighlightChar (Rail c) = c-fromHighlightChar (Cross c) = c-fromHighlightChar (If c) = c-fromHighlightChar (Mixed c) = c---end: HighlightChar operations----begin: Field operations-getFieldChar :: Field -> Char-getFieldChar (Field  hChar _) = fromHighlightChar hChar--getFieldVisited :: Field -> Bool-getFieldVisited (Field _ visited) = visited---end: Field operations----begin: Function operations-getFunctionFields :: Function -> [[Field]]-getFunctionFields (Function _ fields) = fields--getFunctionName :: Function -> String-getFunctionName (Function name _) = name---end: Function operations----begin: Programm operations-getProgrammFunctions :: Programm -> [Function]-getProgrammFunctions (Programm functions) = functions---end: Programm operations----begin: Move operations-isAllowed :: Move -> Bool-isAllowed (Forbidden _) = False-isAllowed (Allowed _) = True--fromAllowed :: Move -> (Int,Int)-fromAllowed (Allowed coord) = coord---end: Move operations----begin: Operations for converting code - Strings to the ADT 'Programm'-codeToProgramm :: [String] -> Programm-codeToProgramm content = Programm $ map getFunctionByContentChunk $ splitContentInChunks content--splitContentInChunks :: [String] -> [[String]]-splitContentInChunks content = filterEmptyElements $ (split . keepDelimsL . whenElt) isStartSymbol content-    where isStartSymbol line | null line = False-                             | otherwise = (\(x:xs) -> x == '$') line--filterEmptyElements :: [[String]] -> [[String]]-filterEmptyElements = map (filter (/="")).filter (/=[])--getFunctionByContentChunk :: [String] -> Function-getFunctionByContentChunk functionCode@(x:xs) = Function functioName $ readFunctionCodeToAdtFunction functionCode 0-    where functioName = splitWhen (=='\'') x !! 1--readFunctionCodeToAdtFunction :: [String] -> Int -> [[Field]]-readFunctionCodeToAdtFunction [] _ = []-readFunctionCodeToAdtFunction (e:es) lineCount = readStringToFieldList e (0,lineCount) :  readFunctionCodeToAdtFunction es (succ lineCount)--readStringToFieldList :: String -> (Int,Int) -> [Field]-readStringToFieldList [] _ = []-readStringToFieldList (e:es) (x,y) = Field (Undefined e) False : readStringToFieldList es (succ x,y)---end: Operations for converting code - Strings to the ADT 'Programm'---begin: Operations for modify and access 'Field' in a structure-getFieldByCoord :: [[Field]] -> (Int,Int) -> Field-getFieldByCoord fields (x,y) = (fields !! y) !! x--isVisited :: (Int,Int) -> Function -> Bool-isVisited (x,y) (Function _ fields) = b -           where (Field _ b) = getFieldByCoord fields (x,y)---markAsVisited :: (Int,Int) -> Function -> Function-markAsVisited (x,y) (Function n fields) = Function n $ up ++ ((left ++ [Field e True] ++ tail right) : tail down)-           where (up,down) = splitAt y fields-                 (left,right) = splitAt x (head down)-                 (Field e _) = head right--setFieldAt :: Move -> Function -> Field -> Function-setFieldAt (Allowed (x,y)) (Function n fields) field = Function n $ up ++ ((left ++ [field] ++ tail right) : tail down)-           where (up,down) = splitAt y fields-                 (left,right) = splitAt x (head down)----end: Operations for modify and access 'Field' in a structure---begin: Functions to decide how the train will move-getNextMove :: (Int,Int) -> Direction -> Function -> Bool -> Move-getNextMove (x,y) direction (Function name fields) includeSecondaryBranch = case direction of-                North      -> getNorthMove (x,y) fields includeSecondaryBranch-                South      -> getSouthMove (x,y) fields includeSecondaryBranch-                West       -> getWestMove (x,y) fields includeSecondaryBranch-                East       -> getEastMove (x,y) fields includeSecondaryBranch-                NorthWest  -> getNorthWestMove (x,y) fields includeSecondaryBranch-                NorthEast  -> getNorthEastMove (x,y) fields includeSecondaryBranch-                SouthWest  -> getSouthWestMove (x,y) fields includeSecondaryBranch-                SouthEast  -> getSouthEastMove (x,y) fields includeSecondaryBranch--getNorthMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getNorthMove (x,0) _ includeSecondaryBranch= Forbidden (x,0)-getNorthMove (x,1) _ includeSecondaryBranch= Forbidden (x,1)-getNorthMove (x,y) fields includeSecondaryBranch= Allowed (x,pred y)--getSouthMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getSouthMove (x,y) fields includeSecondaryBranch-        | length fields <= y' = Forbidden (x,y)-        | otherwise = Allowed (x,y')-            where y' = succ y--getEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getEastMove (x,y) fields includeSecondaryBranch-        | length (fields !! y) <= x' = Forbidden (x,y)-        | otherwise = Allowed (succ x,y)-            where x' = succ x--getWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getWestMove (0,y) _ includeSecondaryBranch = Forbidden (0,y)-getWestMove (x,y) _ includeSecondaryBranch = Allowed (pred x,y)--{--        Primary:    Secondary:      Secondary2:-          \            --\              |-           \                            \--}-getNorthWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getNorthWestMove (x,y) fields includeSecondaryBranch-        | primary /= ' ' = Allowed (x',y')-        | includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))-        | otherwise = Forbidden (x,y)-            where x' = pred x-                  y' = pred y-                  primary | x <= 0 || y <= 1 || length (fields !! y') <= x' = ' '-                          | otherwise =getFieldChar $ getFieldByCoord fields (x',y')-                  secondary = secondaryChar == '-'-                  secondary2 = secondaryChar2 == '|'-                  secondaryChar | x == 0 = ' '-                            	| otherwise = getFieldChar $ getFieldByCoord fields (x',y)-                  secondaryChar2 | y <= 1 || length (fields !! y') <= x = ' '-                             	 | otherwise = getFieldChar $ getFieldByCoord fields (x,y')--{--        Primary:     Secondary:      Secondary2:-           /             /-              |-          /                              /--}--getNorthEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getNorthEastMove (x,y) fields includeSecondaryBranch-        | primary /= ' ' = Allowed (x',y')-        | includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))-        | otherwise = Forbidden (x,y)-            where x' = succ x-                  y' = pred y-                  primary | y <= 1 || length (fields !! y') <= x' = ' '-                          | otherwise = getFieldChar $ getFieldByCoord fields (x',y')-                  secondary = secondaryChar == '-'-                  secondary2 = secondaryChar2 == '|'-                  secondaryChar | length (fields !! y) <= x' = ' '-                            | otherwise = getFieldChar $ getFieldByCoord fields (x',y)-                  secondaryChar2 | y <= 1 || length (fields !! y') <= x = ' '-                             | otherwise = getFieldChar $ getFieldByCoord fields (x,y')-{--     Primary:       Secondary:      Secondary2:-       /               -/               /-      /                                 |--}--getSouthWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getSouthWestMove (x,y) fields includeSecondaryBranch-        | primary /= ' ' = Allowed (x',y')-        | includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))-        | otherwise = Forbidden (x,y)-           where x' = pred x-                 y' = succ y-                 primary | length fields <= y' || x == 0 = ' '-                         | otherwise = getFieldChar $ getFieldByCoord fields (x',y')-                 secondary = secondaryChar == '-'-                 secondary2 = secondaryChar2 == '|'-                 secondaryChar2 | length fields <= y' || length (fields !! y') <= x = ' '-                                | otherwise = getFieldChar $ getFieldByCoord fields (x,y')-                 secondaryChar | x == 0 = ' '-                               | otherwise = getFieldChar $ getFieldByCoord fields (x',y)--{--    Primary:     Seondary:      Secondary2:-    \               \-              \-     \                              |--}-getSouthEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move-getSouthEastMove (x,y) fields includeSecondaryBranch-        | primary /= ' ' = Allowed (x',y')-        | includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))-        | otherwise = Forbidden (x,y)-           where x' = succ x-                 y' = succ y-                 primary | length fields <= y' || length (fields !! y') <= x' = ' '-                         | otherwise = getFieldChar $ getFieldByCoord fields (x',y')-                 secondary = secondaryChar == '-'-                 secondary2 = secondaryChar2 == '|'-                 secondaryChar | length (fields !! y) <= x' = ' '-                               | otherwise = getFieldChar $ getFieldByCoord fields (x',y)-                 secondaryChar2 | length fields <= y' || (length (fields !! y') <= x) = ' '-                                | otherwise = getFieldChar $ getFieldByCoord fields (x,y')--getSecondary :: Bool -> (Int,Int) -> Bool -> (Int,Int) -> (Int,Int)-getSecondary secondary1 coord1 secondary2 coord2 -        | secondary1  = coord1-        | otherwise = coord2--getNewDirection :: Char -> Direction -> Direction-getNewDirection newChar oldDir-        | isJust newDir = fromJust newDir-        | otherwise = oldDir-    where dirMap = [((SouthEast,'-'),East),-                    ((SouthWest,'-'),West),-                    ((East,'/'),NorthEast),-                    ((West,'\\'),NorthWest),-                    ((East,'\\'),SouthEast),-                    ((West,'/'),SouthWest),-                    ((SouthEast,'|'),South),-                    ((NorthEast,'|'),North),-                    ((SouthWest,'|'),South),-                    ((NorthWest,'|'),North),-                    ((South,'/'),SouthWest),-                    ((South,'\\'),SouthEast),-                    ((North,'\\'),NorthWest),-                    ((North,'/'),NorthEast)]-          newDir = lookup (oldDir,newChar) dirMap----end: Functions to decide how the train will move-xor :: Bool -> Bool -> Bool-xor a b = a /= b--goStep :: Move -> Function -> Direction -> (Move,Function,Direction)-goStep (Forbidden a) function dir  = (Forbidden a,function,dir)-goStep (Allowed (x,y)) function@(Function _ fields) dir = (nextCoord,visitedFunction,newDir)-            where visitedFunction = markAsVisited (x,y) function-                  nextCoord = getNextMove (x,y) dir visitedFunction True-                  newDir | isAllowed nextCoord = getNewDirection (getFieldChar(getFieldByCoord fields ( fromAllowed nextCoord))) dir-                         | otherwise = dir--exCode3 = ["$ 'main'"," \\","  \\","   \\----\\","         \\","         |","     #---/"]-exFunction3 = getFunction exCode3--exCode2 = ["$ 'main'"," \\ /----\\","  \\     |","   \\----/"]-exFunction2 = getFunction exCode2-getFunction code = e-    where (Programm (e:es)) = codeToProgramm code-
src/RailEditor/Execute.hs view
@@ -5,9 +5,28 @@ import System.Exit  -- Compiles the open file-compile :: Window --Main Window which contain the path to the open File+compile :: String -- Input filepath+  -> String -- output filepath   -> IO (ExitCode,String,String)-compile window = do-  path <- get window windowTitle-  readProcessWithExitCode "dist/build/RailCompiler/RailCompiler" -    ["-c","-i",path,"-o",((reverse.(takeWhile(/='/')).reverse)path)] ""+compile input output = readProcessWithExitCode "dist/build/RailCompiler/RailCompiler"+    ["-c","-i",input,"-o",output] ""++--linkes copmiled railcode with llvm+linkLlvm :: String --Compiled code+  -> String -- executable path+  -> IO (ExitCode,String,String)+linkLlvm compiledCode exe =+--src/RailCompiler/*.ll dose not work.+  readProcessWithExitCode "llvm-link" [compiledCode,"src/RailCompiler/cmp.ll",+    "src/RailCompiler/linked_stack.ll","src/RailCompiler/math.ll",+    "src/RailCompiler/list.ll","src/RailCompiler/stack.ll",+    "src/RailCompiler/string.ll","-o",exe] ""++--executes the executable+executeRail :: String+  -> String+  -> IO (ExitCode,String,String)+executeRail exeName = +  readProcessWithExitCode "lli" [exeName]+  +
+ src/RailEditor/FooterBar.hs view
@@ -0,0 +1,50 @@+{- |+Module      :  FooterBar.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT++Stability   :  experimental++The FooterBar-module depicts the footer bar at the bottom of the main-window.+-}+module FooterBar (+  create,+  Footer,+  getContainer,+  setPosition,+  setMode+                 )+  where++    -- imports --+import qualified KeyHandler as KH+import qualified Graphics.UI.Gtk as Gtk+    -- functions --++-- | encapsulates information about the footer+data Footer = Foot {getContainer :: Gtk.HBox,+                    getCurrentPositionLabel :: Gtk.Label,+                    getModeLabel :: Gtk.Label}++-- | sets the label displaying the current position+setPosition :: Footer -> (Int,Int) -> IO ()+setPosition footer (x,y) =+  Gtk.labelSetText (getCurrentPositionLabel footer) ("(" ++ show x ++ "," ++ show y ++ ")")++-- | set the label displaying the current mode+setMode :: Footer -> KH.InputMode -> IO ()+setMode footer KH.Replace = Gtk.labelSetText (getModeLabel footer) "Mode: Replace"+setMode footer KH.Insert = Gtk.labelSetText (getModeLabel footer) "Mode: Insert"+setMode footer KH.Smart = Gtk.labelSetText (getModeLabel footer) "Mode: Smart"++-- | creates a footer+create = do+  hboxInfoLine <- Gtk.hBoxNew False 0++  modeLabel <- Gtk.labelNew $ Just "Mode: Insert"+  currentLabel <- Gtk.labelNew $ Just "(0,0)"++  Gtk.boxPackEnd hboxInfoLine currentLabel Gtk.PackNatural 3+  Gtk.boxPackStart hboxInfoLine modeLabel Gtk.PackNatural 3+  return $ Foot hboxInfoLine currentLabel modeLabel
+ src/RailEditor/Highlighter.hs view
@@ -0,0 +1,159 @@+{-+Module : Highlighter.hs+Description : .+Maintainer : Chritoph Graebnitz, Marcus Hoffmann(c)+License : MIT++Stability : experimental++This Modul provides a function to color the colorMap of textAreaContent.+It uses primary the Lexer modul to step the IP of the code and highlight+by the way.+-}+module Highlighter (+                    highlight   -- highlights all entries saved in the data structur of the TextAreaCotent-module+                   )+  where++import InterfaceDT as IDT+import Preprocessor as PRE+import Lexer+import qualified TextAreaContent as TAC+import qualified Control.Exception as EXC+import Graphics.UI.Gtk.Abstract.Widget+import System.IO+import Data.IORef+import Data.Maybe+import qualified Data.Map as Map++--returns the grid2D from a IDT.IPL grid2D+getGrid2dFromPreProc2Lexer(IDT.IPL grid2D) = grid2D++-- highlights all entries saved in the data structur of the TextAreaCotent-module+highlight :: TAC.TextAreaContent -> IO()+highlight textAC =+  EXC.catch (do+    pGrid <- TAC.getPositionedGrid textAC+    let (IDT.IPL positionedGrid) = pGrid+    (xm,ym) <- TAC.size textAC+    paintItRed textAC+    highlightFcts positionedGrid textAC+    return ()+    ) handleErrors++--Handels errors and prints them out used in context of Lexer and Preprocessor+handleErrors :: EXC.ErrorCall  -> IO ()+handleErrors e = print(show e)++-- highlight all rail-functions+highlightFcts ::  [PositionedGrid]-- List of funtions in line-representation with y coord of function(position of $) +  -> TAC.TextAreaContent             -- Char coloring information+  -> IO IP+highlightFcts [] _ = return crash+highlightFcts (x:xs) textAC = do+  highlightFct (fst x) start (snd x) textAC Map.empty+  highlightFcts xs textAC+  +  {-+ main highlighting process which highlights a single rail-function.+ Colors:+   comments : red+   $ # : gold+   rails : black+   built in function blue+   constans green+ parseIP returns the current lexeme and IP. In case of constants IP+ is at the closing char.+-}+highlightFct :: Grid2D+  -> IP+  -> Int+  -> TAC.TextAreaContent+  -> Map.Map (Int,Int) [Lexer.Direction] --Map of colored positions+  -> IO IP+highlightFct grid2D ip yOffset textAC mOCPos+  | ip == crash = return crash+  |otherwise = if isPosColored mOCPos (posx ip,posy ip) (dir ip)+  then return crash+  else+   case lex of+    Nothing -> do+      TAC.putColor textAC (xC,yC) TAC.black+      highlightFct grid2D nextIP yOffset textAC inMap+    Just (Junction _) -> do+      TAC.putColor textAC (xC,yC) TAC.gold+      let (falseIP,trueIP) = junctionturns grid2D parseIP+      highlightFct grid2D falseIP yOffset textAC inMap+      highlightFct grid2D trueIP yOffset textAC inMap+    Just (Lambda _) -> do+      TAC.putColor textAC (xC,yC) TAC.gold+      let (lip,bip) = lambdadirs parseIP+      highlightFct grid2D (step grid2D lip) yOffset textAC inMap+      highlightFct grid2D (step grid2D bip) yOffset textAC inMap+    Just (Constant str)   ->+      if [current grid2D parseIP] == "]" || +         [current grid2D parseIP] == "["+      then colorStrCommand str TAC.green+      else do+        TAC.putColor textAC (xC,yC) TAC.green+        highlightFct grid2D (step grid2D parseIP)yOffset textAC inMap+    Just (Push str)-> colorStrCommand str TAC.blue+    Just (Pop str) -> colorStrCommand str TAC.green+    Just (Call str) -> colorStrCommand str TAC.green+    _ -> do+      cBlue+      cGold+      if lex == Just Finish+      then return crash+      else highlightFct grid2D nextIP yOffset textAC inMap+    where+      (lex, parseIP) = parse grid2D ip+      nextIP = step grid2D parseIP+      x = posx ip+      y = posy ip+      xC = fromIntegral x+      yC = fromIntegral $ y+yOffset+      inMap = Map.alter (Just . maybe [dir ip] ((:) (dir ip))) (x,y) mOCPos+      -- colors Start and finish gold+      cGold ::IO ()+      cGold | fromJust lex `elem` [Start,Finish] = TAC.putColor textAC (xC,yC) TAC.gold+            | otherwise = return()+      -- colors rail-builtins blue+      cBlue :: IO ()+      cBlue | fromJust lex `elem` [NOP,Boom,EOF,Input,Output,IDT.Underflow,+              RType,Add1,Divide,Multiply,Subtract,Remainder,Cut,Append,Size,Nil,+              Cons,Breakup,Greater,Equal] = TAC.putColor textAC (xC,yC) TAC.blue+            | otherwise = return()+      --function to color commands with strings like [], {}+      colorStrCommand :: String -> TAC.RGBColor -> IO IP+      colorStrCommand str color = do+        colorMoves grid2D (turnaround ip)+          (turnaround parseIP) color textAC+        highlightFct grid2D (step grid2D parseIP) yOffset textAC inMap+      --steps the IP to the beginning of an constant, call or pop+      colorMoves :: Grid2D -> IP -> IP -> TAC.RGBColor -> TAC.TextAreaContent-> IO IP+      colorMoves grid2D endIP curIP color textAC +        | endIP == curIP = do+          TAC.putColor textAC (x,y) color+          return crash+        | otherwise = do+          TAC.putColor textAC (x,y) color+          colorMoves grid2D endIP (move curIP Forward) color textAC+          return crash+        where+          x = fromIntegral $ posx curIP+          y = fromIntegral $ posy curIP+yOffset+          +-- colors all entry red+-- This function is needed to recolor after editing+paintItRed :: TAC.TextAreaContent -> IO ()+paintItRed = TAC.deleteColors+  +-- Is the position colored?+isPosColored :: Map.Map (Int,Int) [Lexer.Direction]+  -> (Int,Int)+  -> Lexer.Direction+  -> Bool+isPosColored mOCPos pos dir =+  elem dir $ Map.findWithDefault [] pos mOCPos+
+ src/RailEditor/InteractionField.hs view
@@ -0,0 +1,164 @@+{- |+Module      :  InteractionField.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT++Stability   :  experimental++The InteractionField-module depicts the interaction-field on the right side of the main-window that contains the input, output, function-stack, variable-stack.+-}+module InteractionField (+-- *Constructors+  create,+-- *Types+  InteractionDT,+-- *Methods+  getContainer,+  getInputBuffer,+  getOutputBuffer,+  getDataStackBuffer,+  getFunctionStackBuffer,+  textViewWindowShow +                        )+  where++    -- imports --++import qualified Graphics.UI.Gtk as Gtk+    -- functions --+++-- | encapsulates the Information needed for manipulating the InteractionField+data InteractionDT = InterDT { getContainer :: Gtk.VBox,+                               getInputBuffer :: Gtk.TextBuffer,+                               getOutputBuffer :: Gtk.TextBuffer,+                               getFunctionStackBuffer :: Gtk.TextBuffer,+                               getDataStackBuffer :: Gtk.TextBuffer}++-- | creates an interactionField+create = do+  -- create Buffer+  bufferIn <- Gtk.textBufferNew Nothing+  bufferOut <- Gtk.textBufferNew Nothing+  bufferStackFunc <- Gtk.textBufferNew Nothing+  bufferStackVar <- Gtk.textBufferNew Nothing++  -- create Labels with corresponding view (for displaying the buffer content)+  labelIn <- Gtk.labelNewWithMnemonic "Input:"+  viewIn <- Gtk.textViewNewWithBuffer bufferIn+  labelOut <- Gtk.labelNewWithMnemonic "Output:"+  viewOut <- Gtk.textViewNewWithBuffer bufferOut+  labelStackFunc <- Gtk.labelNewWithMnemonic "Functionstack"+  viewStackFunc <- Gtk.textViewNewWithBuffer bufferStackFunc+  labelStackVar <- Gtk.labelNewWithMnemonic "Datastack"+  viewStackVar <- Gtk.textViewNewWithBuffer bufferStackVar++  Gtk.textViewSetEditable viewStackFunc False+  Gtk.textViewSetEditable viewStackVar False++  -- create Buttons for zoomed view+  buttonPopUpIn <- Gtk.buttonNewWithLabel ""+  setButtonProps buttonPopUpIn+  buttonPopUpOut <- Gtk.buttonNewWithLabel ""+  setButtonProps buttonPopUpOut+  buttonPopUpStackF <- Gtk.buttonNewWithLabel ""+  setButtonProps buttonPopUpStackF+  buttonPopUpStackV <- Gtk.buttonNewWithLabel ""+  setButtonProps buttonPopUpStackV++  -- set Button events+  Gtk.onClicked buttonPopUpIn $ Gtk.postGUIAsync $ textViewWindowShow bufferIn "Input"+  Gtk.onClicked buttonPopUpOut $ Gtk.postGUIAsync $ textViewWindowShow bufferOut "Output"+  Gtk.onClicked buttonPopUpStackF $ Gtk.postGUIAsync $ textViewWindowShow bufferStackFunc "Function-Stack"+  Gtk.onClicked buttonPopUpStackV $ Gtk.postGUIAsync $ textViewWindowShow bufferStackVar "Data-Stack"++  -- compose Input+  hboxLabelButtonIn <- Gtk.hBoxNew False 0+  Gtk.boxPackStart hboxLabelButtonIn labelIn Gtk.PackNatural 1+  Gtk.boxPackEnd hboxLabelButtonIn buttonPopUpIn Gtk.PackNatural 0++  -- compose output+  hboxLabelButtonOut <- Gtk.hBoxNew False 0+  Gtk.boxPackStart hboxLabelButtonOut labelOut Gtk.PackNatural 1+  Gtk.boxPackEnd hboxLabelButtonOut buttonPopUpOut Gtk.PackNatural 0++  -- create container with label and button for function-stack+  boxStackFunc <- Gtk.vBoxNew False 0+  hboxLabelButtonFunc <- Gtk.hBoxNew False 0+  Gtk.boxPackStart hboxLabelButtonFunc labelStackFunc Gtk.PackNatural 0+  Gtk.boxPackEnd hboxLabelButtonFunc buttonPopUpStackF Gtk.PackNatural 10+  Gtk.boxPackStart boxStackFunc hboxLabelButtonFunc Gtk.PackNatural 0++  -- make FunctionStack-view scrollable+  swinStackF  <- Gtk.scrolledWindowNew Nothing Nothing+  Gtk.scrolledWindowSetPolicy swinStackF Gtk.PolicyAutomatic Gtk.PolicyAutomatic+  Gtk.containerAdd swinStackF viewStackFunc+  Gtk.boxPackStart boxStackFunc swinStackF Gtk.PackGrow 0++  -- create container with label and button for data-stack+  boxStackVar <- Gtk.vBoxNew False 0+  hboxLabelButtonVar <- Gtk.hBoxNew False 0+  Gtk.boxPackStart hboxLabelButtonVar labelStackVar Gtk.PackNatural 0+  Gtk.boxPackEnd hboxLabelButtonVar buttonPopUpStackV Gtk.PackNatural 10+  Gtk.boxPackStart boxStackVar hboxLabelButtonVar Gtk.PackNatural 0++  -- make DataStack-view scrollable+  swinStackV <- Gtk.scrolledWindowNew Nothing Nothing+  Gtk.scrolledWindowSetPolicy swinStackV Gtk.PolicyAutomatic Gtk.PolicyAutomatic+  Gtk.containerAdd swinStackV viewStackVar+  Gtk.boxPackStart boxStackVar swinStackV Gtk.PackGrow 0++  -- pack the container with the stacks in one container+  boxStack <- Gtk.hBoxNew True 0+  Gtk.boxPackStart boxStack boxStackFunc Gtk.PackGrow 2+  Gtk.boxPackStart boxStack boxStackVar Gtk.PackGrow 2+++  -- create main Container+  boxView <- Gtk.vBoxNew False 0++  -- add label and zoom-button to main container+  Gtk.boxPackStart boxView hboxLabelButtonIn Gtk.PackNatural 2+  -- make Input scrollable+  swinIn <- Gtk.scrolledWindowNew Nothing Nothing+  Gtk.scrolledWindowSetPolicy swinIn Gtk.PolicyAutomatic Gtk.PolicyAutomatic+  Gtk.containerAdd swinIn viewIn+  -- add input to main container+  Gtk.boxPackStart boxView swinIn Gtk.PackGrow 0+  inSap <- Gtk.hSeparatorNew+  Gtk.boxPackStart boxView inSap Gtk.PackNatural 2+  -- add label and zoom-button to main container+  Gtk.boxPackStart boxView hboxLabelButtonOut Gtk.PackNatural 2+  -- make Output scrollable+  swinOut <- Gtk.scrolledWindowNew Nothing Nothing+  Gtk.scrolledWindowSetPolicy swinOut Gtk.PolicyAutomatic Gtk.PolicyAutomatic+  Gtk.containerAdd swinOut viewOut+  -- add Output to main container+  Gtk.boxPackStart boxView swinOut Gtk.PackGrow 1+  outSap <- Gtk.hSeparatorNew+  Gtk.boxPackStart boxView outSap Gtk.PackNatural 2+  -- add Stacks to main container+  Gtk.boxPackStart boxView boxStack Gtk.PackGrow 1++  return $ InterDT boxView bufferIn bufferOut bufferStackFunc bufferStackVar++-- shows a window displaying the textBuffer+textViewWindowShow textBuffer title = do+  window <- Gtk.windowNew+  Gtk.windowSetDefaultSize window 400 300+  Gtk.windowSetPosition window Gtk.WinPosCenter+  swin <- Gtk.scrolledWindowNew Nothing Nothing+  Gtk.scrolledWindowSetPolicy swin Gtk.PolicyAutomatic Gtk.PolicyAutomatic+  textView <- Gtk.textViewNewWithBuffer textBuffer+  Gtk.containerAdd swin textView+  Gtk.set window [Gtk.containerChild Gtk.:= swin,+                  Gtk.windowTitle Gtk.:= title]+  Gtk.widgetShowAll window+  return ()++-- sets the properties of a zoom button+setButtonProps button = do+  image <- Gtk.imageNewFromFile "rail-graphics/full.png"+  Gtk.buttonSetImage button image+  Gtk.buttonSetImagePosition button Gtk.PosRight
+ src/RailEditor/Interpreter.hs view
@@ -0,0 +1,422 @@+module Interpreter (+                    addBreak, removeBreak, toggleBreak,+                    interpret, step, reset+                   )+  where+  import qualified Graphics.UI.Gtk as Gtk+  import qualified InterfaceDT as IDT+  import qualified TextAreaContent as TAC+  import qualified Lexer+  import qualified Data.Map as Map+  import Control.Monad+  import Data.IORef+  import Data.Maybe+  import Data.List+  import qualified Data.Foldable++  type Funcmap = Map.Map String IDT.PositionedGrid++  getCurrentText buffer = do+    start <- Gtk.textBufferGetStartIter buffer+    end <- Gtk.textBufferGetEndIter buffer+    Gtk.textBufferGetText buffer start end True++  checkStep tac flag action = do+    cnt <- readIORef (TAC.context tac)+    isBlocked <- blocked tac+    let flags = TAC.railFlags cnt+    if flag `elem` flags && null (TAC.funcStack cnt)+    then showError tac "Please reset, before you change the execution mode"+    else do+      unless (TAC.Interpret `elem` flags) $ writeIORef (TAC.context tac) cnt{TAC.railFlags = TAC.Interpret:flags}+      if TAC.Blocked `elem` flags+      then do+        putStrLn "is blocked"+        unless isBlocked $ do+          putStrLn "unblock"+          inputAfterBlock tac+          writeIORef (TAC.context tac) cnt{TAC.railFlags = delete TAC.Blocked flags}+      else action++  addBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()+  addBreak tac position = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.breakMap = Map.insert position True (TAC.breakMap cnt)}++  removeBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()+  removeBreak tac position = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.breakMap = Map.delete position (TAC.breakMap cnt)}++  toggleBreak :: TAC.TextAreaContent -> TAC.Position -> IO ()+  toggleBreak tac position = do+    cnt <- readIORef (TAC.context tac)+    if isNothing $ Map.lookup position (TAC.breakMap cnt)+    then addBreak tac position+    else removeBreak tac position++  reset :: TAC.TextAreaContent -> IO ()+  reset tac = do+    abortExecution tac+    Gtk.textBufferSetText (snd $ TAC.buffer tac) ""+    Gtk.textBufferSetText (fst $ TAC.buffer tac) ""++  abortExecution :: TAC.TextAreaContent -> IO ()+  abortExecution tac = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) (TAC.IC [] [] (TAC.breakMap cnt) 0 (-1,-1) [])++  init :: TAC.TextAreaContent -> IO ()+  init tac = do+    reset tac+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.funcStack = [("main", Lexer.start, Map.empty)]}++  blocked :: TAC.TextAreaContent -> IO Bool+  blocked tac = do+    cnt <- readIORef (TAC.context tac)+    let offset = TAC.inputOffset cnt+        buffer = fst $ TAC.buffer tac+    currentText <- getCurrentText buffer+    putStrLn $ "off:" ++ show offset ++ "; "++ show (length currentText)+    return $ offset  > length currentText++  showError :: TAC.TextAreaContent -> String -> IO ()+  showError tac string = do+    showMessage tac ("Error: " ++ string)+    abortExecution tac++  showMessage :: TAC.TextAreaContent -> String -> IO ()+  showMessage tac message = showRawMessage (message ++ "\n") (snd $ TAC.buffer tac)++  showRawMessage :: String -> Gtk.TextBuffer -> IO ()+  showRawMessage message buffer = do+    end <- Gtk.textBufferGetEndIter buffer+    Gtk.textBufferInsert buffer end message++  updateCurIPPos :: TAC.TextAreaContent -> Funcmap -> IO ()+  updateCurIPPos tac fmap = do+    cnt <- readIORef (TAC.context tac)+    unless (null $ TAC.funcStack cnt) $ do+      let ((fname, ip, _):_) = TAC.funcStack cnt+          offset = snd $ fromJust $ Map.lookup fname fmap+      writeIORef (TAC.context tac) cnt{TAC.curIPPos = (Lexer.posx ip, Lexer.posy ip + offset)}+  +  interpret' :: TAC.TextAreaContent -> Funcmap -> IO ()+  interpret' tac funcmap = do+    dostep tac funcmap+    updateCurIPPos tac funcmap+    stop <- needsHalt tac funcmap+    unless stop $ interpret' tac funcmap++  interpret :: TAC.TextAreaContent -> IO ()+  interpret tac = checkStep tac TAC.Step $ do+    putStrLn "noBlock"+    funcmap <- getFunctions tac+    interpret' tac funcmap++  step tac = checkStep tac TAC.Interpret $ do+    funcmap <- getFunctions tac+    dostep tac funcmap+    updateCurIPPos tac funcmap++  inputAfterBlock :: TAC.TextAreaContent -> IO ()+  inputAfterBlock tac = do+    cnt <- readIORef (TAC.context tac)+    let offset = TAC.inputOffset cnt+    let buffer = fst $ TAC.buffer tac+    currentText <- getCurrentText buffer+    putStrLn "read"+    let char = currentText !! offset+    writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString [char]:TAC.dataStack cnt}++  dostep :: TAC.TextAreaContent -> Funcmap -> IO ()+  dostep tac funcmap = do+    cnt <- readIORef (TAC.context tac)+    let fstack = TAC.funcStack cnt+    when (null fstack) (Interpreter.init tac)+    cnt <- readIORef (TAC.context tac)+    let ((fname, ip, vars):xs) = TAC.funcStack cnt+    if isNothing $ Map.lookup fname funcmap+    then showError tac $ "Function '" ++ fname ++ "' not found"+    else do+      let+          grid = fst $ fromJust $ Map.lookup fname funcmap+          tmpip = Lexer.step grid ip+          (maylex, newip) = Lexer.parse grid tmpip+      writeIORef (TAC.context tac) cnt{TAC.funcStack = (fname, newip, vars):xs}+      Data.Foldable.forM_ maylex (perform tac funcmap)++  perform :: TAC.TextAreaContent -> Funcmap -> IDT.Lexeme -> IO ()+  perform tac _ IDT.Boom = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else+      if not $ isString $ head $ TAC.dataStack cnt+      then showError tac "Element on top of stack is no String"+      else do+        showMessage tac (show $ head $ TAC.dataStack cnt)+        abortExecution tac+  -- TODO+  perform tac _ IDT.EOF = return ()+  perform tac _ IDT.Input = do+    cnt <- readIORef (TAC.context tac)+    let offset = TAC.inputOffset cnt+    writeIORef (TAC.context tac) cnt{TAC.inputOffset = succ offset}+    isBlocked <- blocked tac+    if isBlocked+    then do+      let flags = TAC.railFlags cnt+      writeIORef (TAC.context tac) cnt{TAC.railFlags = TAC.Blocked:flags}+      putStrLn "blocken"+      return ()+    else do+      let buffer = fst $ TAC.buffer tac+      start <- Gtk.textBufferGetStartIter buffer+      end <- Gtk.textBufferGetEndIter buffer+      currentText <- Gtk.textBufferGetText buffer start end True+      writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString [currentText !! offset]:TAC.dataStack cnt}++  perform tac _ IDT.Output = do+    cnt <- readIORef (TAC.context tac)+    let dataSt = TAC.dataStack cnt+    if null dataSt+    then showError tac "Empty Stack"+    else if (\(TAC.RailString _:_) -> True) dataSt+         then do +            showRawMessage ((\(TAC.RailString t:_) -> t) dataSt) (snd $ TAC.buffer tac)+            writeIORef (TAC.context tac) cnt{TAC.dataStack = tail (TAC.dataStack cnt)}+         else showError tac "Element on top of the stack is no String"+  perform tac _ IDT.Underflow = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.dataStack = (TAC.RailString $ show $ length $ TAC.dataStack cnt):TAC.dataStack cnt}+  perform tac _ IDT.RType = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else writeIORef (TAC.context tac) cnt{TAC.dataStack = typeOf (head $ TAC.dataStack cnt):tail (TAC.dataStack cnt)}+  perform tac _ (IDT.Constant string) = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString string:TAC.dataStack cnt}+  perform tac _ (IDT.Push string) = do+    cnt <- readIORef (TAC.context tac)+    let res = searchVar string (TAC.funcStack cnt)+    if isNothing res+    then showError tac ("Variable '" ++ string ++ "' not found")+    else writeIORef (TAC.context tac) cnt{TAC.dataStack = fromJust res:TAC.dataStack cnt}+  perform tac _ (IDT.Pop string) = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else do+      let ((fname, ip, vars):xs) = TAC.funcStack cnt+          nvars = Map.insert string (head $ TAC.dataStack cnt) vars+      writeIORef (TAC.context tac) cnt{TAC.dataStack = tail $ TAC.dataStack cnt, TAC.funcStack = (fname, ip, nvars):xs}+  perform tac _ (IDT.Call string) = do+    cnt <- readIORef (TAC.context tac)+    if null string+    then+      if null (TAC.dataStack cnt)+      then showError tac "Empty stack"+      else+        if not $ isLambda $ head $ TAC.dataStack cnt+        then showError tac "Wrong type on stack, string expected"+        else do+          let (TAC.RailLambda fn ip map:xs) = TAC.dataStack cnt+          writeIORef (TAC.context tac) cnt{TAC.funcStack = (fn, ip, map):TAC.funcStack cnt, TAC.dataStack = xs}+    else writeIORef (TAC.context tac) cnt{TAC.funcStack = (string, Lexer.start, Map.empty):TAC.funcStack cnt}+  perform tac _ IDT.Add1 = performMath tac (+)+  perform tac _ IDT.Divide = performMath tac div -- may be needed to adjust according to compiler+  perform tac _ IDT.Multiply = performMath tac (*)+  perform tac _ IDT.Remainder = performMath tac rem+  perform tac _ IDT.Subtract = performMath tac (-)+  perform tac _ IDT.Cut = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)+    then showError tac "Not enough elements on stack"+    else do+      let (e1:e2:xs) = TAC.dataStack cnt+      if not (isNumeric e1) || not (isString e2)+      then showError tac "Wrong types on stack, number and string expected"+      else do+        let (TAC.RailString s1, TAC.RailString s2) = (e1, e2)+        if length s2 > (read s1 :: Int)+        then showError tac "Cut number bigger than string length"+        else do+          let (lres, rres) = splitAt (read s1 :: Int) s2+          writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailString rres:TAC.RailString lres:xs}+  perform tac _ IDT.Append = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)+    then showError tac "Not enough elements on stack"+    else do+      let (e1:e2:xs) = TAC.dataStack cnt+      if not (isString e1) || not (isString e2)+      then showError tac "Wrong types on stack, strings expected"+      else do+        let (TAC.RailString s1, TAC.RailString s2) = (e1, e2)+            res = TAC.RailString (s2 ++ s1)+        writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}+  perform tac _ IDT.Size = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else+      if not $ isString $ head $ TAC.dataStack cnt+      then showError tac "Wrong type on stack, string expected"+      else do+        let (TAC.RailString str:xs) = TAC.dataStack cnt+            res = TAC.RailString $ show $ length str+        writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}+  perform tac _ IDT.Nil = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailList []:TAC.dataStack cnt}+  perform tac _ IDT.Cons = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)+    then showError tac "Not enough elements on stack"+    else+      if not $ isList $ head $ tail $ TAC.dataStack cnt+      then showError tac "Wrong type on second position of stack, list expected"+      else do+        let (x:TAC.RailList lst:xs) = TAC.dataStack cnt+        writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailList (x:lst):xs}+  perform tac _ IDT.Breakup = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else+      if not $ isList $ head $ TAC.dataStack cnt+      then showError tac "Wrong type on stack, list expected"+      else do+        let (TAC.RailList lst:xs) = TAC.dataStack cnt+        if null lst+        then showError tac "Empty list cannot be splitted"+        else do+          let (y:ys) = lst+          writeIORef (TAC.context tac) cnt{TAC.dataStack = y:TAC.RailList ys:xs}+  perform tac _ IDT.Greater = performMath tac (\x y -> if x > y then 1 else 0)+  perform tac _ IDT.Equal = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)+    then showError tac "Not enough elements on stack"+    else do+      let (e1:e2:xs) = TAC.dataStack cnt+          res = TAC.RailString (if e1 == e2 then "1" else "0")+      writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}+  perform tac _ IDT.Finish = do+    cnt <- readIORef (TAC.context tac)+    writeIORef (TAC.context tac) cnt{TAC.funcStack = tail $ TAC.funcStack cnt, TAC.curIPPos = (-1, -1)}+  perform tac fmap (IDT.Junction _) = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt)+    then showError tac "Empty stack"+    else+      if not $ isBool $ head $ TAC.dataStack cnt+      then showError tac "Wrong type on stack, boolean expected"+      else do+        let ((fname, ip, vars):xs) = TAC.funcStack cnt+            (fip, tip) = Lexer.junctionturns (fst $ fromJust $ Map.lookup fname fmap) ip+            nip = if head (TAC.dataStack cnt) == TAC.RailString "0" then fip else tip+        writeIORef (TAC.context tac) cnt{TAC.dataStack = tail $ TAC.dataStack cnt, TAC.funcStack = (fname, nip, vars):xs}+  perform tac _ (IDT.Lambda _) = do+    cnt <- readIORef (TAC.context tac)+    let ((fname, ip, vars):xs) = TAC.funcStack cnt+        (lip, nip) = Lexer.lambdadirs ip+    writeIORef (TAC.context tac) cnt{TAC.dataStack = TAC.RailLambda fname lip vars:TAC.dataStack cnt, TAC.funcStack = (fname, nip, vars):xs}++  performMath :: TAC.TextAreaContent -> (Int -> Int -> Int) -> IO ()+  performMath tac op = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.dataStack cnt) || null (tail $ TAC.dataStack cnt)+    then showError tac "Not enough elements on stack"+    else do+      let (e1:e2:xs) = TAC.dataStack cnt+      if not (isNumeric e1) || not (isNumeric e2)+      then showError tac "Wrong types on stack, numbers expected"+      else do+        let (TAC.RailString n1, TAC.RailString n2) = (e2, e1) -- switching might be necessary+            res = TAC.RailString $ show $ (read n1 :: Int) `op` (read n2 :: Int)+        writeIORef (TAC.context tac) cnt{TAC.dataStack = res:xs}++  searchVar :: String -> [(String, Lexer.IP, Map.Map String TAC.RailType)] -> Maybe TAC.RailType+  searchVar _ [] = Nothing+  searchVar var ((_, _, vars):xs)+    | isNothing $ Map.lookup var vars = searchVar var xs+    | otherwise = Map.lookup var vars++  getFunctions :: TAC.TextAreaContent -> IO Funcmap+  getFunctions tac = do+    pGrid <- TAC.getPositionedGrid tac+    let (IDT.IPL funcs) = pGrid+    let resmap = Map.empty+    addnames resmap funcs+   where+    addnames resmap [] = return resmap+    addnames resmap (x:xs) = do+      fname <- funcname tac (fst x)+      let newmap = Map.insert fname x resmap+      addnames newmap xs++  getFunctionWith :: TAC.TextAreaContent -> TAC.Position -> IO (String, IDT.Grid2D)+  getFunctionWith tac position = do+    pGrid <- TAC.getPositionedGrid tac+    let (IDT.IPL funcs) = pGrid+        funclist = filter isJust $ map (\(f, y) -> if y <= snd position then Just f else Nothing) funcs+    if null funclist+    then return ("", Map.empty)+    else do+      let res = fromJust $ last funclist+      fname <- funcname tac res+      return (fname, res)++  funcname :: TAC.TextAreaContent -> IDT.Grid2D -> IO String+  funcname tac code = case Lexer.funcname code of+    (Left fname) -> return fname+    (Right error) -> do+      showError tac "No function name"+      return ""++  needsHalt :: TAC.TextAreaContent -> Funcmap -> IO Bool+  needsHalt tac fmap = do+    cnt <- readIORef (TAC.context tac)+    if null (TAC.funcStack cnt)+    then return True+    else do+      putStrLn "check"+      let (fname, ip, _) = head $ TAC.funcStack cnt+      let pos = (Lexer.posx ip, Lexer.posy ip + snd (fromJust $ Map.lookup fname fmap))+      print (Map.findWithDefault False pos (TAC.breakMap cnt))+      return $ Map.findWithDefault False pos (TAC.breakMap cnt)++  isNumeric :: TAC.RailType -> Bool+  isNumeric (TAC.RailString string) = all (`elem` "0123456789") string+  isNumeric _ = False++  isList :: TAC.RailType -> Bool+  isList (TAC.RailList _) = True+  isList _ = False++  isNil :: TAC.RailType -> Bool+  isNil (TAC.RailList []) = True+  isNil _ = False++  isString :: TAC.RailType -> Bool+  isString (TAC.RailString _) = True+  isString _ = False++  isBool :: TAC.RailType -> Bool+  isBool (TAC.RailString string) = string == "0" || string == "1"+  isBool _ = False++  isLambda :: TAC.RailType -> Bool+  isLambda TAC.RailLambda{} = True+  isLambda _ = False++  typeOf :: TAC.RailType -> TAC.RailType+  typeOf var+    | isString var = TAC.RailString "string"+    | isNil var = TAC.RailString "nil"+    | isList var = TAC.RailString "list"+    | isLambda var = TAC.RailString "lambda"
+ src/RailEditor/KeyHandler.hs view
@@ -0,0 +1,622 @@+{- |+Module      :  KeyHandler.hs+Description :  .+Maintainer  :  Kristin Knorr, Nicolas Lehmann, Benjamin Kodera (c)+License     :  MIT++Stability   :  stable++The KeyHandler-module allows to react on keypress-events in the editor.+-}+module KeyHandler (+                   handleKey,   -- handles keypress-events+                   InputMode(Insert, Replace,Smart)+                  )+  where++import Graphics.UI.Gtk+import Control.Monad+import Data.Maybe+import qualified TextAreaContent as TAC+import qualified TextAreaContentUtils as TACU+import qualified RedoUndo as History+import qualified Interpreter+import qualified Selection++data InputMode = Replace | Insert | Smart deriving (Eq)++-- | handleKey passes key depending on Entrymode and handles RedoUndo Shortcuts.+handleKey :: TAC.TextAreaContent+  -> TAC.Position+  -> InputMode+  -> [Modifier]+  -> String+  -> KeyVal+  -> IO TAC.Position+handleKey tac pos modus modif key val =+  if Control `elem` modif then+    handleControlKeys tac pos modus modif (keyToChar val)+  else+    case modus of+      Insert -> handleKeyIns tac pos modif key val+      Replace -> handleKeyRP tac pos modif key val+      Smart -> handleKeySpec tac pos modif key val++handleControlKeys :: TAC.TextAreaContent+  -> TAC.Position+  -> InputMode+  -> [Modifier]+  -> Maybe Char+  -> IO TAC.Position+handleControlKeys tac pos modus modif char +  | char `elem` [Just 'z', Just 'Z'] = +    if Shift `elem` modif+    then History.redo tac pos+    else History.undo tac pos+  | char `elem` [Just 'a', Just 'A'] = do+    positions <- TAC.getPositons tac+    Selection.updateCells tac positions True+  | char `elem` [Just 'c', Just 'C'] = do+    TAC.setClipboard tac+    return pos+  | char `elem` [Just 'v', Just 'V'] =+    if modus `elem` [Insert,Smart] then Selection.pasteInsert tac pos+    else Selection.pasteReplace tac pos+  | char == Just 'b' = +    Interpreter.toggleBreak tac pos >> return pos  --set breakpoint+  | otherwise = return pos+  +-- | handles keys in Insert-mode+handleKeyIns :: TAC.TextAreaContent+  -> TAC.Position+  -> [Modifier]+  -> String+  -> KeyVal+  -> IO TAC.Position+handleKeyIns tac pos@(x,y) modif key val+  | isJust (keyToChar val) || key == "dead_circumflex" = handlePrintKeyIns tac pos key val+  | isArrow key = handleArrowsIns key pos tac+  | otherwise = case key of+    "BackSpace" -> handleBackSpace tac pos+    "Return" -> handleReturn tac pos+    "Tab" -> handleTab tac pos modif+    "ISO_Left_Tab" -> handleTab tac pos modif+    "Delete" -> handleDelete tac pos+    "Home" -> return (0, y)+    "End" -> do +      finX <- TAC.findLastChar tac y+      return (if finX == (-1) then 0 else finX + 1, y)+    _ -> return pos++-- | handles keys in Replace-mode+handleKeyRP :: TAC.TextAreaContent+  -> TAC.Position+  -> [Modifier]+  -> String+  -> KeyVal+  -> IO TAC.Position+handleKeyRP tac pos@(x,y) modif key val+  | isJust (keyToChar val) || key == "dead_circumflex" = handlePrintKeyRP tac pos key val+  | isArrow key = handleArrowsIns key pos tac+  | otherwise = case key of+    "BackSpace" -> handleBackSpace tac pos+    "Return" -> handleReturn tac pos+    "Tab" -> handleTab tac pos modif+    "ISO_Left_Tab" -> handleTab tac pos modif+    "Delete" -> handleDelete tac pos+    "Home" -> return (0,y)+    "End" -> do+      finX <- TAC.findLastChar tac y+      return (if finX==(-1) then 0 else finX+1,y)+    _ -> return pos++-- | handles keys in Smart-mode+handleKeySpec :: TAC.TextAreaContent+  -> TAC.Position+  -> [Modifier]+  -> String+  -> KeyVal+  -> IO TAC.Position+handleKeySpec tac pos@(x,y) modif key val+  | elemNumBlock key = handleNumBlock tac pos key+  | isJust (keyToChar val) || key=="dead_circumflex" = handlePrintKeySpec tac pos key val+  | isArrow key && Control `elem` modif = arrowDirectionSetter tac key >> return pos+  | isArrow key = handleArrowsSpec key pos tac+  | otherwise =+      case key of+        "BackSpace" -> handleBackSpaceSpec tac pos+        "Return" -> handleReturnRail tac pos+        "Tab" -> handleTab tac pos modif+        "ISO_Left_Tab" -> handleTab tac pos modif+        "Delete" -> TAC.deleteCell tac pos >> return pos+        "Home" -> return (0,y)+        "End" -> do+          finX <- TAC.findLastChar tac y+          return (finX+1,y)+        _ -> return pos++printableKeyInit tac pos key val = do+  Selection.clear tac pos+  let char = if key=="dead_circumflex" then '^' else fromJust $ keyToChar val+  cell <- TAC.getCell tac pos+  return (cell, char)++-- | handling of printable keys in Replace-mode (overwriting)+handlePrintKeyRP :: TAC.TextAreaContent+  -> TAC.Position+  -> String+  -> KeyVal+  -> IO TAC.Position+handlePrintKeyRP tac pos@(x,y) key val = do+  (cell,char) <- printableKeyInit tac pos key val+  let ((curchar,isSelected), _) = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) cell+  History.action tac pos (TAC.Replace [(curchar,False)] [(char,False)])+  TAC.putCell tac pos ((char,isSelected),TAC.defaultColor)+  return (x+1,y)++-- | handling of printable keys in Replace-mode and Smart-mode (overwriting)+handlePrintKeySpec :: TAC.TextAreaContent+  -> TAC.Position+  -> String+  -> KeyVal+  -> IO TAC.Position+handlePrintKeySpec tac pos@(x,y) key val = do+  (cell,char) <- printableKeyInit tac pos key val+  dir@(dx,dy) <- TAC.getDirection tac+  if char `elem` "*+x^v><-|/\\@"+  then do+    let+      newDir@(nx,ny) = getNewDirection char dir +      (content@(curchar,isSelected), _) = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) cell+      newChar = buildJunction curchar char+    History.action tac pos (TAC.Replace [content] [(newChar,False)])+    TAC.putCell tac pos ((newChar,False),TAC.defaultColor)+    TAC.putDirection tac newDir+    return (max 0 (x+nx),max 0 (y+ny))+  else do+    let (content@(curchar,isSelected), _) = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) cell+    History.action tac pos (TAC.Replace [content] [(char,False)])+    TAC.putCell tac pos ((char,False),TAC.defaultColor)+    return (max 0 (x+dx),max 0 (y+dy))++-- | handling of printable keys in Insert-mode+handlePrintKeyIns :: TAC.TextAreaContent+  -> TAC.Position+  -> String+  -> KeyVal+  -> IO TAC.Position+handlePrintKeyIns tac pos@(x,y) key val = do+  Selection.clear tac pos+  let char = if key=="dead_circumflex" then '^' else fromJust $ keyToChar val+  History.action tac pos (TAC.Insert [(char,False)])+  TACU.moveChars tac pos (1,0)+  TAC.putCell tac pos ((char,False),TAC.defaultColor)+  return (x+1,y)++-- | checking if key is numblock key+elemNumBlock :: String+  -> Bool+elemNumBlock key = key `elem` ["KP_End", "KP_Down",+  "KP_Page_Down", "KP_Right", "KP_Page_Up",+  "KP_Up", "KP_Home", "KP_Left"]++-- | checking if key is an arrow +isArrow :: String -> Bool+isArrow key = key `elem` ["Left", "Right", "Up", "Down"]++-- | handles arrows in Insert-mode and Replace-mode+handleArrowsIns :: String+  -> TAC.Position+  -> TAC.TextAreaContent+  -> IO TAC.Position+handleArrowsIns key pos@(x,y) tac = do+  Selection.deselect tac+  (maxX,maxY) <- TAC.size tac+  case key of+    "Left" +      | x==0 && y==0 -> return (x,y)+      | x==0 -> do+        finPrev <- TAC.findLastChar tac (y-1)+        return (finPrev+1,y-1)+      | otherwise -> return (x-1,y)+    "Right" ->+      return $ if x==maxX && y==maxY then (x,y) else +        if x==maxX then (0,y+1) else (x+1,y)+    "Up" ->+      if y==0+      then return (x,y)+      else do+        finPrev <- TAC.findLastChar tac (y-1)+        return $ if finPrev<x then (finPrev+1,y-1) else (x,y-1)+    "Down" ->+      if y==maxY+      then return (x,y)+      else do+        finNext <- TAC.findLastChar tac (y+1)+        return $ if finNext<x then (finNext+1,y+1) else (x,y+1)++-- | handles arrows in Smart-mode+handleArrowsSpec :: String+  -> TAC.Position+  -> TAC.TextAreaContent+  -> IO TAC.Position+handleArrowsSpec key pos@(x,y) tac = do+  Selection.deselect tac+  (maxX,maxY) <- TAC.size tac+  case key of+    "Left" -> return $+      if x==0 && y==0+      then (x,y)+      else+        if x==0+        then (maxX,y-1)+        else (x-1,y)+    "Right" -> return $+      if x==maxX && y==maxY+      then (x,y)+      else+        if x==maxX+        then (0,y+1)+        else (x+1,y)+    "Up" -> return $ if y==0 then (x,y) else (x,y-1)+    "Down" -> return $ if y==maxY then (x,y) else (x,y+1)++-- |sets direction after setting new cursor focus+arrowDirectionSetter :: TAC.TextAreaContent+  -> String+  -> IO()+arrowDirectionSetter tac key = do+  dir@(x,y)<- TAC.getDirection tac+  case key of+    "Left" -> TAC.putDirection tac (-1,y)+    "Right" -> TAC.putDirection tac (1,y)+    "Up" -> TAC.putDirection tac (x,-1)+    "Down" -> TAC.putDirection tac (x,1)++deleteSelection tac bottomRight topLeft x xRight xLeft y yBottom yTop doMove = do+  when doMove $ TACU.moveChars tac bottomRight+    (if (x, y) == topLeft then (x - xRight - 1, y - yBottom) else (xLeft - x, yTop - y))+  action <- TACU.mvLinesUp tac y (abs (yTop-y)) (TAC.DoNothing, (xLeft, yTop))+  History.action tac (x, y) (fst action)+  return (xLeft,yTop)++-- | handles Backspace-key+handleBackSpace :: TAC.TextAreaContent+  -> TAC.Position+  -> IO TAC.Position +handleBackSpace tac (x,y) = do+  selectedPositions <- TAC.getSelectedPositons tac+  (topLeft@(xLeft,yTop),bottomRight@(xRight,yBottom)) <- Selection.clear tac (x,y)+  case (x,y) of+    (0,0) -> return (0,0)+    (0,_) ->+      if null selectedPositions then do -- no previous selection+        finXPrev <- TAC.findLastChar tac (y-1)+        History.action tac (finXPrev+1,y-1) TAC.RemoveLine+        TACU.moveLinesUp tac y+        return (finXPrev+1,y-1)+      else deleteSelection tac bottomRight topLeft x xRight xLeft y yBottom yTop False+    (_,_) -> do+      empty <- TAC.isEmptyLine tac y+      if empty+      then return(0,y)+      else+        if null selectedPositions then do -- no previous selection+          maybeCell <- TAC.getCell tac (x-1,y)+          let cell = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) maybeCell+          History.action tac (x-1,y) (TAC.Remove [fst cell])+          TAC.deleteCell tac (x-1,y)+          TACU.moveChars tac (x,y) (-1,0)+          return (x-1,y)+        else deleteSelection tac bottomRight topLeft x xRight xLeft y yBottom yTop True+++-- | handles Backspace-key in smart mode+handleBackSpaceSpec :: TAC.TextAreaContent+  -> TAC.Position+  -> IO TAC.Position +handleBackSpaceSpec tac pos@(x,y) = do+  selectedPositions <- TAC.getSelectedPositons tac+  if selectedPositions/=[]+  then handleBackSpace tac pos+  else do+    dir@(dx,dy) <- TAC.getDirection tac+    cell <- TAC.getCell tac pos+    prevCell <- TAC.getCell tac (x-dx,y-dy)+    if isNothing cell+    then+      if isNothing prevCell+      then handleBackSpace tac pos+      else handleBackSpaceSpec tac (x-dx,y-dy)+    else do+      let (content@(char,_), col) = fromJust cell+      if char `elem` "x+*"+      then do+        oldChar <- findOldChar tac pos dir char+        TAC.putCell tac pos ((oldChar,False), col)+        return (max 0 (x-dx),max 0 (y-dy))+      else do+        oldDir@(nx,ny) <- findOldDir tac pos dir+        TAC.deleteCell tac pos+        TAC.putDirection tac oldDir+        return (max 0 (x-nx),max 0 (y-ny))++-- | handles Return-key in Smart-mode+handleReturnRail :: TAC.TextAreaContent+  -> TAC.Position+  -> IO TAC.Position+handleReturnRail tac pos@(x,y) = do+  History.action tac pos TAC.InsertLine+  TACU.moveLinesDownXShift tac pos False+  return (x,y+1)++-- | handles Return-key in Insert-mode and Replace-mode+handleReturn :: TAC.TextAreaContent+  -> TAC.Position+  -> IO TAC.Position+handleReturn tac pos@(x,y) = do+  Selection.clear tac pos+  History.action tac pos TAC.InsertLine+  TACU.moveLinesDownXShift tac pos True+  return (0,y+1)++-- | handles Tab-key and Shift-Tab+handleTab :: TAC.TextAreaContent+  -> TAC.Position+  -> [Modifier]+  -> IO TAC.Position+handleTab tac pos@(x,y) modif = do+  prevCharX <- TACU.findLastCharBefore tac (x-1) y+  finX <- TAC.findLastChar tac y+  case modif of+    [Shift] ->+      if prevCharX == (-1)+      then+        if x>3+        then do+          History.action tac (x-4,y) (TAC.Remove (replicate 4 (' ', False)))+          TACU.moveChars tac pos (-4,0)+          return (x-4,y)+        else do+          History.action tac (0,y) (TAC.Remove (replicate x (' ', False)))+          TACU.moveChars tac pos (-x,0)+          return (0,y)+      else return pos+    _ -> do+      selectedPositions <- TAC.getSelectedPositons tac+      if null selectedPositions then do+        History.action tac pos (TAC.Insert (replicate 4 (' ', False)))+        TACU.moveChars tac pos (4,0)+        return(x+4,y)+      else do +        shiftLines tac $ Selection.getFirstPositions selectedPositions+        return pos+        +-- | handles tab for selected lines        +shiftLines :: TAC.TextAreaContent -> [TAC.Position] -> IO ()+shiftLines _ [] = return ()+shiftLines tac (pos:rest) = do+  TACU.moveChars tac pos (4,0)+  shiftLines tac rest+  +-- | handles Delete-key+handleDelete :: TAC.TextAreaContent+  -> TAC.Position+  -> IO TAC.Position+handleDelete tac pos@(x,y) = do+  selectedPositions <- TAC.getSelectedPositons tac+  (topLeft@(xLeft,yTop),bottomRight@(xRight,yBottom)) <- Selection.clear tac (x,y)+  finX <- TAC.findLastChar tac y+  if x==finX+1+  then do+    History.action tac pos TAC.RemoveLine+    TACU.moveLinesUp tac (y+1)+    return (x,y)+  else+    if null selectedPositions then do -- no previous selection+      maybeCell <- TAC.getCell tac pos+      let cell = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) maybeCell+      History.action tac pos (TAC.Remove [fst cell])+      TAC.deleteCell tac (x,y)+      TACU.moveChars tac (x+1,y) (-1,0)+      return pos+    else deleteSelection tac bottomRight topLeft x xRight xLeft y yBottom yTop True++-- Rail Smart-mode setting of Cursor-Position+-- directions+dNW :: TAC.Direction+dNW = (-1,-1)+dN :: TAC.Direction+dN = (0,-1)+dNO :: TAC.Direction+dNO = (1,-1)+dW :: TAC.Direction+dW = (-1,0)+dD :: TAC.Direction+dD = (0,0)+dO :: TAC.Direction+dO = (1,0)+dSW :: TAC.Direction+dSW = (-1,1)+dS :: TAC.Direction+dS = (0,1)+dSO :: TAC.Direction+dSO = (1,1)++-- | find new direction, sets (1,0) if input is undefined+getNewDirection :: Char -> TAC.Direction -> TAC.Direction+getNewDirection _ (0,0) = (1,0)+getNewDirection '*' x = x+getNewDirection '@' (x,y) = (-x,-y)+getNewDirection '+' dir+  |dir `elem` [dS, dN, dW, dO] = dir+  |otherwise = dD+getNewDirection 'x' dir+  | dir `elem` [dSO, dSW, dNO, dNW] = dir+  | otherwise = dD+getNewDirection '|' dir+  | dir `elem` [dS, dSW, dSO] = dS+  | dir `elem` [dN, dNO, dNW] = dN+  | otherwise = dD+getNewDirection '-' dir+  | dir `elem` [dO, dSO, dNO] = dO+  | dir `elem` [dW, dSW, dNW] = dW+  | otherwise = dD+getNewDirection '/' dir+  | dir `elem` [dO, dN, dNO] = dNO+  | dir `elem` [dW, dS, dSW] = dSW+  | otherwise = dD+getNewDirection '\\' dir+  | dir `elem` [dW, dN, dNW] = dNW+  | dir `elem` [dS, dO, dSO] = dSO+  | otherwise = dD+getNewDirection '<' dir+  | dir == dO  = dSO+  | dir == dSW = dW+  | dir == dNW = dNO+  | otherwise  = dD+getNewDirection '>' dir+  | dir == dW  = dNW+  | dir == dNO = dO+  | dir == dSO = dSW+  | otherwise  = dD+getNewDirection 'v' dir+  | dir == dN  = dNO+  | dir == dSO = dS+  | dir == dSW = dNW+  | otherwise  = dD+getNewDirection '^' dir+  | dir == dS  = dSW+  | dir == dNO = dSO+  | dir == dNW = dN+  | otherwise  = dD++-- | builds a junction in case of crossing rails+buildJunction :: Char -> Char -> Char+buildJunction content char+  | content == '|' && char == '-' || content == '-' && char == '|' = '+'+  | content == '\\' && char == '/' || content == '/' && char == '\\' = 'x'+  | content `elem` "/\\" && char `elem` "-|" || content `elem` "-|" && char `elem` "/\\" = '*'+  | content `elem` "+*" && (char == '-' || char == '|') = content+  | content `elem` "x*" && (char == '/' || char == '\\') = content+  | content == '+' && (char == '/' || char == '\\') = '*'+  | content == 'x' && (char == '-' || char == '|') = '*'+  | content == '*' && char `elem` "-|/\\+x*" = content+  | content == TAC.defaultChar = char+  | otherwise = content++-- | finds old char, when one Rail is deleted+findOldChar :: TAC.TextAreaContent+  -> TAC.Position+  -> TAC.Direction+  -> Char+  -> IO Char+findOldChar tac pos@(x,y) dir char+  |(dir==dN || dir==dS) && char=='+' = return '-'+  |(dir==dO || dir==dW) && char=='+' = return '|'+  |(dir==dNO || dir==dSW) && char=='x' = return '\\'+  |(dir==dSO || dir==dNW) && char=='x' = return '/'+  |(dir==dN || dir==dS) && char=='*' = do+    (nb1,nb2,nb3) <- findNeighbours tac (x-1,y-1) (x-1,y) (x-1,y+1)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return '*'+      (Just _ , _ , Just _) -> return 'x'+      (_,_,Just _) -> return '/'+      (Just _, _, _) -> return '\\'+      otherwise -> return ' '+  |(dir==dO || dir==dW) && char=='*' = do+    (nb1,nb2,nb3) <- findNeighbours tac (x-1,y-1) (x,y-1) (x+1,y-1)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return '*'+      (Just _ , _ , Just _) -> return 'x'+      (_,_,Just _) -> return '/'+      (Just _, _, _) -> return '\\'+      otherwise -> return ' '+  |(dir==dNO || dir==dSW) && char=='*' = do+    (nb1,nb2,nb3) <- findNeighbours tac (x,y-1) (x-1,y-1) (x-1,y)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return '*'+      (Just _ , _ , Just _) -> return '+'+      (_,_,Just _) -> return '-'+      (Just _, _, _) -> return '|'+      otherwise -> return ' '+  |(dir==dSO || dir==dNW) && char=='*' = do+    (nb1,nb2,nb3) <- findNeighbours tac (x,y-1) (x+1,y-1) (x+1,y)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return '*'+      (Just _ , _ , Just _) -> return '+'+      (_,_,Just _) -> return '-'+      (Just _, _, _) -> return '|'+      otherwise -> return ' '++findOldDir :: TAC.TextAreaContent+  -> TAC.Position+  -> TAC.Direction+  -> IO TAC.Direction+findOldDir tac pos@(x,y) dir@(dx,dy)+  |dir `elem` [dSO,dNO,dSW,dNW] = do+    (nb1,nb2,nb3) <- findNeighbours tac (x-dx,y) (x-dx,y-dy) (x,y-dy)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return dir+      (_,_,Just _) -> return (0,dy)+      (Just _, _, _) -> return (dx,0)+      otherwise -> return (0,0)+  |dir `elem` [dS,dN] = do+    (nb1,nb2,nb3) <- findNeighbours tac (x-1,y-dy) (x,y-dy) (x+1,y-dy)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return dir+      (_,_,Just _) -> return (-1,dy)+      (Just _, _, _) -> return (1,dy)+      otherwise -> return (0,0)+  |dir `elem` [dO,dW] = do+    (nb1,nb2,nb3) <- findNeighbours tac (x-dx,y-1) (x-dx,y) (x-dx,y+1)+    case (nb1,nb2,nb3) of+      ( _ , Just _, _ ) -> return dir+      (_,_,Just _) -> return (dx,-1)+      (Just _, _, _) -> return (dx,1)+      otherwise -> return (0,0)+  |otherwise = return (0,0)++-- | neighbours of position depending on direction+findNeighbours :: TAC.TextAreaContent+  -> TAC.Position+  -> TAC.Position+  -> TAC.Position+  -> IO(Maybe ((Char,Bool),TAC.RGBColor),+      Maybe ((Char,Bool),TAC.RGBColor),+      Maybe ((Char,Bool),TAC.RGBColor))+findNeighbours tac (x1,y1) (x2,y2) (x3,y3) = do+  n1<-TAC.getCell tac (x1,y1)+  n2<-TAC.getCell tac (x2,y2)+  n3<-TAC.getCell tac (x3,y3)+  return(n1,n2,n3)++-- | inserts matching character and sets new position+handleNumBlock :: TAC.TextAreaContent+  -> TAC.Position+  -> String+  -> IO TAC.Position+handleNumBlock tac pos@(x,y) key = do+  cell <- TAC.getCell tac pos+  let+    (char,(dx,dy)) = getDirAndCharFromNumKey key+    (content@(curchar,isSelected), _) = fromMaybe ((TAC.defaultChar, False), TAC.defaultColor) cell+    newChar = buildJunction curchar char+  History.action tac pos (TAC.Replace [content] [(newChar,False)])+  TAC.putCell tac pos ((newChar,False),TAC.defaultColor)+  TAC.putDirection tac (dx,dy)+  return (max 0 (x+dx),max 0 (y+dy))++-- | analysng which character and direction equals key+getDirAndCharFromNumKey :: String+  -> (Char,TAC.Direction)+getDirAndCharFromNumKey key =+  case key of+    "KP_End"       -> ('/',dSW)+    "KP_Down"      -> ('|',dS)+    "KP_Page_Down" -> ('\\',dSO)+    "KP_Right"     -> ('-',dO)+    "KP_Page_Up"   -> ('/',dNO)+    "KP_Up"        -> ('|',dN)+    "KP_Home"      -> ('\\',dNW)+    "KP_Left"      -> ('-',dW)
− src/RailEditor/Main.hs 
@@ -1,192 +0,0 @@-module Main where--import Graphics.UI.Gtk-import Data.Map as Map-import Control.Monad.Trans (liftIO)-import Data.IORef-import Data.Maybe-import Menu-import TextArea-import Control.Concurrent--main :: IO()-main = do-    initGUI-    splashScreen <- getSplashScreen-    window <- windowNew-    label <- labelNewWithMnemonic "Hi" --    bufferIn <- textBufferNew Nothing-    bufferOut <- textBufferNew Nothing-    bufferStackFunc <- textBufferNew Nothing-    bufferStackVar <- textBufferNew Nothing--    labelIn <- labelNewWithMnemonic "Input:"-    viewIn <- textViewNewWithBuffer bufferIn-    labelOut <- labelNewWithMnemonic "Output:"-    viewOut <- textViewNewWithBuffer bufferOut-    labelStackFunc <- labelNewWithMnemonic "Functionstack"-    viewStackFunc <- textViewNewWithBuffer bufferStackFunc-    labelStackVar <- labelNewWithMnemonic "Variablestack"-    viewStackVar <- textViewNewWithBuffer bufferStackVar--    buttonPopUpIn <- buttonNewWithLabel ""-    setButtonProps buttonPopUpIn-    buttonPopUpOut <- buttonNewWithLabel ""-    setButtonProps buttonPopUpOut-    buttonPopUpStackF <- buttonNewWithLabel ""-    setButtonProps buttonPopUpStackF-    buttonPopUpStackV <- buttonNewWithLabel ""-    setButtonProps buttonPopUpStackV--    layout <- layoutNew Nothing Nothing-    lwin <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy lwin PolicyAutomatic PolicyAutomatic-    containerAdd lwin layout-    textArea <- textAreaNew layout 10 10--    onClicked buttonPopUpIn $ postGUIAsync $ textViewWindowShow bufferIn "Input"-    onClicked buttonPopUpOut $ postGUIAsync $ textViewWindowShow bufferOut "Output"-    onClicked buttonPopUpStackF $ postGUIAsync $ textViewWindowShow bufferStackFunc "Function-Stack"-    onClicked buttonPopUpStackV $ postGUIAsync $ textViewWindowShow bufferStackVar "Variable-Stack"--    hboxLabelButtonIn <- hBoxNew False 0-    boxPackStart hboxLabelButtonIn labelIn PackNatural 1-    boxPackEnd hboxLabelButtonIn buttonPopUpIn PackNatural 0--    hboxLabelButtonOut <- hBoxNew False 0-    boxPackStart hboxLabelButtonOut labelOut PackNatural 1-    boxPackEnd hboxLabelButtonOut buttonPopUpOut PackNatural 0--    hboxInfoLine <- hBoxNew False 0-    modeLabel <- labelNew $ Just "Mode: Replace"-    currentLabel <- labelNew $ Just "(0,0)"-    boxPackEnd hboxInfoLine currentLabel PackNatural 3-    boxPackStart hboxInfoLine modeLabel PackNatural 3--    boxStackFunc <- vBoxNew False 0-    hboxLabelButtonFunc <- hBoxNew False 0-    boxPackStart hboxLabelButtonFunc labelStackFunc PackNatural 0-    boxPackEnd hboxLabelButtonFunc buttonPopUpStackF PackNatural 10-    boxPackStart boxStackFunc hboxLabelButtonFunc PackNatural 0-    swinStackF  <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy swinStackF PolicyAutomatic PolicyAutomatic-    containerAdd swinStackF viewStackFunc-    boxPackStart boxStackFunc swinStackF PackGrow 0--    boxStackVar <- vBoxNew False 0-    hboxLabelButtonVar <- hBoxNew False 0-    boxPackStart hboxLabelButtonVar labelStackVar PackNatural 0-    boxPackEnd hboxLabelButtonVar buttonPopUpStackV PackNatural 10-    boxPackStart boxStackVar hboxLabelButtonVar PackNatural 0-    swinStackV <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy swinStackV PolicyAutomatic PolicyAutomatic-    containerAdd swinStackV viewStackVar-    boxPackStart boxStackVar swinStackV PackGrow 0--    boxStack <- hBoxNew True 0-    boxPackStart boxStack boxStackFunc PackGrow 2-    boxPackStart boxStack boxStackVar PackGrow 2--    boxView <- vBoxNew False 0-    boxLay <- hBoxNew False 0-    boxPackStart boxView hboxLabelButtonIn PackNatural 2-    swinIn <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy swinIn PolicyAutomatic PolicyAutomatic-    containerAdd swinIn viewIn-    boxPackStart boxView swinIn PackGrow 0-    inSap <- hSeparatorNew-    boxPackStart boxView inSap PackNatural 2-    boxPackStart boxView hboxLabelButtonOut PackNatural 2-    swinOut <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy swinOut PolicyAutomatic PolicyAutomatic-    containerAdd swinOut viewOut-    boxPackStart boxView swinOut PackGrow 1-    outSap <- hSeparatorNew-    boxPackStart boxView outSap PackNatural 2-    boxPackStart boxView boxStack PackGrow 1-    boxPackStart boxLay lwin PackGrow 1-    vSep <- vSeparatorNew-    boxPackStart boxLay vSep PackNatural 2-    boxPackEnd boxLay boxView PackNatural 1--    table <- tableNew 5 1 False--    menuBar <- createMenu window textArea bufferOut-    extraBar <- createExtraBar--    vSepa <- hSeparatorNew--    tableAttach table menuBar 0 1 0 1 [Fill] [Fill] 0 0-    tableAttach table extraBar 0 1 1 2 [Fill] [Fill] 0 0-    tableAttach table boxLay 0 1 2 3 [Expand,Fill] [Expand,Fill] 0 0-    tableAttach table vSepa 0 1 3 4 [Fill] [Fill] 0 0-    tableAttach table hboxInfoLine 0 1 4 5 [Fill] [Fill] 2 2--    set window [containerChild := table, windowDefaultHeight := 550, windowDefaultWidth := 850, windowWindowPosition := WinPosCenter]-    onDestroy window mainQuit-    widgetShowAll window-    widgetDestroy splashScreen-    mainGUI-    return ()--createExtraBar = do-    extraBar <- menuBarNew--    image <- imageNewFromStock stockExecute IconSizeMenu-    run <- imageMenuItemNewWithLabel ""-    imageMenuItemSetImage run image-    menuShellAppend extraBar run-    imageD <- imageNewFromStock stockGoForward IconSizeMenu--    debugg <- imageMenuItemNewWithLabel ""-    imageMenuItemSetImage debugg imageD-    menuShellAppend extraBar debugg--    mode <- menuNew-    replaceMode <- radioMenuItemNewWithLabel "replace"-    insertMode <- radioMenuItemNewWithLabelFromWidget replaceMode "insert"-    smartMode <- radioMenuItemNewWithLabelFromWidget replaceMode "smart"--    modeItem <- menuItemNewWithLabel "mode"-    menuItemSetSubmenu modeItem mode--    menuShellAppend extraBar modeItem--    menuShellAppend mode replaceMode-    menuShellAppend mode insertMode-    menuShellAppend mode smartMode---    return extraBar--setButtonProps button = do-    image <- imageNewFromFile "full.png"-    buttonSetImage button image-    buttonSetImagePosition button PosRight--textViewWindowShow textBuffer title = do-    window <- windowNew-    windowSetDefaultSize window 400 300-    windowSetPosition window WinPosCenter-    swin <- scrolledWindowNew Nothing Nothing-    scrolledWindowSetPolicy swin PolicyAutomatic PolicyAutomatic-    textView <- textViewNewWithBuffer textBuffer-    containerAdd swin textView-    set window [containerChild := swin, windowTitle := title]-    widgetShowAll window-    return ()--getSplashScreen :: IO Window-getSplashScreen = do-    splashScreen <- windowNew-    set splashScreen [windowDefaultHeight := 200, windowDefaultWidth := 400, windowWindowPosition := WinPosCenter, windowTitle := "Starting Editor"]-    windowSetDefaultSize splashScreen 400 200 -    windowSetPosition splashScreen WinPosCenter-    layout <- layoutNew Nothing Nothing-    label <- labelNewWithMnemonic "Rail Editor starting ..."-    layoutPut layout label 30 30-    set splashScreen [containerChild := layout]-    widgetShowAll splashScreen-    return splashScreen-
+ src/RailEditor/MainWindow.hs view
@@ -0,0 +1,104 @@+{- |+Module      :  MainWindow.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT++Stability   :  experimental++The MainWindow-module depicts the main window of the editor.+-}+module MainWindow (+  create+                  )+  where++    -- imports --+import qualified Graphics.UI.Gtk  as Gtk+import qualified MenuBar          as MB+import qualified ToolBar          as TB+import qualified FooterBar        as FB+import qualified TextArea         as TA+import TextAreaContent as TAC+import qualified InteractionField as IAF+import Data.IORef+import qualified Interpreter as IN+import qualified Paths_rail_compiler_editor as Path+import Control.Monad++    -- functions --++afterEvent evt ta footer = +  evt (TA.drawingArea ta) $ \event -> do+    let posRef = TA.currentPosition ta+    readIORef posRef >>= FB.setPosition footer+    return True++-- | creates a mainWindow+create :: IO ()+create = do+  Gtk.initGUI+  -- create and configure main window+  window <- Gtk.windowNew+  iconpath <- Path.getDataFileName "data/icon.png"+  pb <- Gtk.pixbufNewFromFile iconpath+  Gtk.windowSetIcon window (Just pb)+  Gtk.onDestroy window Gtk.mainQuit++  interDT <- IAF.create+  let boxView = IAF.getContainer interDT+  footer <- FB.create+  let hboxInfoLine = FB.getContainer footer++  -- create TextArea with TextAreaContent+  tac <- TAC.init 100 100 (IAF.getInputBuffer interDT) (IAF.getOutputBuffer interDT)+  ta <- TA.initTextAreaWithContent tac+  lwin <- TA.getTextAreaContainer ta++  -- reset label with current position+  afterEvent Gtk.afterKeyPress ta footer++  afterEvent Gtk.afterButtonPress ta footer++  -- pack TextArea and InteractionField+  boxLay <- Gtk.hBoxNew False 0+  Gtk.boxPackStart boxLay lwin Gtk.PackGrow 1+  vSep <- Gtk.vSeparatorNew+  Gtk.boxPackStart boxLay vSep Gtk.PackNatural 2+  Gtk.boxPackEnd boxLay boxView Gtk.PackNatural 1++  table <- Gtk.tableNew 5 1 False+  -- avoid setting focus through key-events+  Gtk.containerSetFocusChain table [Gtk.toWidget $ TA.drawingArea ta]+  -- buffer for plug 'n' play+  let bufferOut = IAF.getOutputBuffer interDT+  let bufferIn  = IAF.getInputBuffer interDT++  Gtk.on bufferIn Gtk.bufferInsertText $ \iter string ->  do+    putStrLn "In"+    tac <- readIORef (TA.textAreaContent ta)+    cnt <- readIORef (TAC.context tac)+    let flags = TAC.railFlags cnt+    if TAC.Interpret `elem` flags+    then IN.interpret tac+    else when (TAC.Step `elem` flags) $ IN.step tac++  menuBar <- MB.create window ta bufferOut bufferIn+  extraBar <- TB.create ta footer interDT++  vSepa <- Gtk.hSeparatorNew++  -- fill table layout+  Gtk.tableAttach table menuBar 0 1 0 1 [Gtk.Fill] [Gtk.Fill] 0 0+  Gtk.tableAttach table extraBar 0 1 1 2 [Gtk.Fill] [Gtk.Fill] 0 0+  Gtk.tableAttach table boxLay 0 1 2 3 [Gtk.Expand,Gtk.Fill] [Gtk.Expand,Gtk.Fill] 0 0+  Gtk.tableAttach table vSepa 0 1 3 4 [Gtk.Fill] [Gtk.Fill] 0 0+  Gtk.tableAttach table hboxInfoLine 0 1 4 5 [Gtk.Fill] [Gtk.Fill] 2 2++  Gtk.set window [Gtk.containerChild Gtk.:= table,+              Gtk.windowDefaultHeight Gtk.:= 550,+              Gtk.windowDefaultWidth Gtk.:= 850,+              Gtk.windowWindowPosition Gtk.:= Gtk.WinPosCenter]+  Gtk.widgetShowAll window+  Gtk.mainGUI+
− src/RailEditor/Menu.hs 
@@ -1,174 +0,0 @@-module Menu where--import TextArea-import Execute-import Graphics.UI.Gtk-import qualified Control.Exception as Exc-import System.Exit-import Data.Maybe-import Control.Monad.IO.Class-import Data.List--{-TODO Refactor text to an 'link' to the entry text-  for the ability to save files-Handels the button press and open or saves a file--}-fileChooserEventHandler :: Window -  -> TextArea-  -> FileChooserDialog -  -> ResponseId-  -> String-  -> IO()-fileChooserEventHandler window area fileChooser response mode-  |response == ResponseOk = do-    dir <- fileChooserGetFilename fileChooser-    let path = fromJust dir-    set window[windowTitle := path] -    case mode of-      "OpenFile" -> do-        content <- readFile path-        deserializeTextArea area content-        syntaxHighlighting area-        widgetDestroy fileChooser-        return()-      "SaveFile" -> do-        code <- (serializeTextAreaContent area)-        writeFile path code-        widgetDestroy fileChooser-        return()-  |response == ResponseCancel = do-    widgetDestroy fileChooser-    return ()-  |otherwise = return ()-  ---checking for a legal path in window title to save whitout dialog-saveFile :: Window -> TextArea -> IO Bool-saveFile window area = do-  code <- serializeTextAreaContent area -  dir <- get window windowTitle-  if "/" `isInfixOf` dir && not("/" `isSuffixOf` dir)-  then do-    writeFile dir code-    return True-  else fileDialog window area "SaveFile" >> return True--{--TODO Refactor text to an 'link' to the entry text-for the ability to save files-Passes the enventhandler for fileDialog and starts it--}-runFileChooser :: Window-  -> TextArea-  -> FileChooserDialog-  -> String-  -> IO()-runFileChooser window area fileChooser mode = do-  on fileChooser response hand-  dialogRun fileChooser-  return()-  where -    hand resp = fileChooserEventHandler window area fileChooser resp mode--{--Setup a file chooser with modes OpenFile and SaveFile-TODO Refactor text to an 'link' to the entry text-for the ability to save files--}-fileDialog :: Window-  -> TextArea-  -> String-  -> IO()-fileDialog window area mode = do-  case mode of-    "OpenFile" -> do-      fileChooser <- fileChooserDialogNew -        (Just mode)-        (Just window)-        FileChooserActionOpen-        [("open",ResponseOk),("cancel",ResponseCancel)]-      runFileChooser window area fileChooser mode-    "SaveFile" -> do-      fileChooser <- fileChooserDialogNew-        (Just mode)-        (Just window)-        FileChooserActionSave-        [("save",ResponseOk),("cancel",ResponseCancel)]-      fileChooserSetDoOverwriteConfirmation fileChooser True-      runFileChooser window area fileChooser mode-  return ()-  --{--TODO Refactor text to an 'link' to the entry text-for the ability to save files-Setups the menu--}-createMenu :: Window-  -> TextArea-  -> TextBuffer-  -> IO MenuBar-createMenu window area output= do-  menuBar <- menuBarNew-- container for menus--  menuFile <- menuNew-  menuHelp <- menuNew--  menuFileItem <- menuItemNewWithLabel "File"-  menuOpenItem <- menuItemNewWithLabel "open crtl+o"-  menuSaveItem <- menuItemNewWithLabel "save ctrl+s"-  menuCloseItem <- menuItemNewWithLabel "quit ctrl+s"-  menuCompileItem <- menuItemNewWithLabel "compile ctrl+F5"-  menuHelpItem <- menuItemNewWithLabel "Help"-  menuAboutItem <- menuItemNewWithLabel "About"-  --Bind the subemenu to menu-  menuItemSetSubmenu menuFileItem menuFile-  menuItemSetSubmenu menuHelpItem menuHelp-  --File and Help menu-  menuShellAppend menuBar menuFileItem-  menuShellAppend menuBar menuHelpItem-  --Insert items in menus-  menuShellAppend menuFile menuOpenItem-  menuShellAppend menuFile menuSaveItem-  menuShellAppend menuFile menuCloseItem-  menuShellAppend menuFile menuCompileItem-  menuShellAppend menuHelp menuAboutItem-  --setting actions for the menu-  on menuOpenItem menuItemActivate (fileDialog -    window -    area-    "OpenFile")-  on menuSaveItem menuItemActivate (saveFile-    window-    area >> return())-  on menuCloseItem menuItemActivate mainQuit-  on menuCompileItem menuItemActivate -    (compileOpenFile window area output >> return ())-  --setting shortcuts in relation to menuBar-  on window keyPressEvent $ do-    modi <- eventModifier-    key <- eventKeyName-    liftIO $ case modi of-      [Control] -> case key of-        "q" -> mainQuit >> return True-        "s" -> saveFile window area  >> return True-        "o" -> fileDialog-          window-          area-          "OpenFile" >> return True-        "F5" -> compileOpenFile window area output-        _ -> return False-      _ -> return False-  return menuBar--compileOpenFile ::Window-  -> TextArea-  -> TextBuffer -  -> IO Bool-compileOpenFile window area output = do-  textBufferSetText output "Compiling Execute"-  (exitCode,out,err) <-compile window-  if exitCode == (ExitSuccess)-  then textBufferSetText output "Compiling succsessful"-  else textBufferSetText output ("Compiling failed: "++['\n']++err)-  return True-
+ src/RailEditor/MenuBar.hs view
@@ -0,0 +1,251 @@+{- |+Module      :  MenuBar.hs+Description :  .+Maintainer  :  Chritoph Graebnitz (c)+License     :  MIT++Stability   :  stable++The MenuBar-module depicts the menu bar at he top of the main window.+-}+module MenuBar (+  create+               )+  where+    +    -- imports --++    -- functions --++import TextArea+import TextAreaContent+import qualified Highlighter as HIGH+import qualified Execute as EXE+import Graphics.UI.Gtk as Gtk+import qualified Control.Exception as Exc+import System.Exit+import Data.Maybe+import Control.Monad.IO.Class+import Control.Monad+import Data.List+import Data.IORef++{-+Handels the button press and open or saves a file+-}+fileChooserEventHandler :: Window +  -> TextArea+  -> FileChooserDialog +  -> ResponseId+  -> String+  -> Gtk.TextBuffer+  -> Gtk.TextBuffer+  -> IO()+fileChooserEventHandler window area fileChooser response mode inputB outputB+  |response == ResponseOk = do+    dir <- fileChooserGetFilename fileChooser+    let path = fromJust dir+    set window[windowTitle := path] +    let contRef = textAreaContent area+    areaContent <- readIORef contRef+    case mode of+      "OpenFile" -> do+        content <- readFile path+        newAreaContent <- deserialize content inputB outputB+        setTextAreaContent area newAreaContent+        widgetDestroy fileChooser+        return()+      "SaveFile" -> do+        code <- serialize areaContent+        writeFile path code+        widgetDestroy fileChooser+        return()+  |response == ResponseCancel = do+    widgetDestroy fileChooser+    return ()+  |otherwise = return ()+  +--checking for a legal path in window title to save whitout dialog+saveFile :: Window -> TextArea -> Gtk.TextBuffer -> Gtk.TextBuffer -> IO Bool+saveFile window area inputB outputB = do+  let contRef = textAreaContent area+  areaContent <- readIORef contRef+  code <- serialize areaContent+  dir <- get window windowTitle+  if "/" `isInfixOf` dir && not("/" `isSuffixOf` dir)+  then do+    writeFile dir code+    return True+  else fileDialog window area "SaveFile" inputB outputB >> return True++{-+TODO Refactor text to an 'link' to the entry text+for the ability to save files+Passes the enventhandler for fileDialog and starts it+-}+runFileChooser :: Window+  -> TextArea+  -> FileChooserDialog+  -> String+  -> Gtk.TextBuffer+  -> Gtk.TextBuffer+  -> IO()+runFileChooser window area fileChooser mode inputB outputB= do+  on fileChooser response hand+  dialogRun fileChooser+  return()+  where +    hand resp = fileChooserEventHandler window area fileChooser resp mode inputB outputB++{-+Setup a file chooser with modes OpenFile and SaveFile+TODO Refactor text to an 'link' to the entry text+for the ability to save files+-}+fileDialog :: Window+  -> TextArea+  -> String+  -> Gtk.TextBuffer+  -> Gtk.TextBuffer+  -> IO()+fileDialog window area mode inputB outputB= do+  case mode of+    "OpenFile" -> do+      fileChooser <- fileChooserDialogNew +        (Just mode)+        (Just window)+        FileChooserActionOpen+        [("open",ResponseOk),("cancel",ResponseCancel)]+      runFileChooser window area fileChooser mode inputB outputB+    "SaveFile" -> do+      fileChooser <- fileChooserDialogNew+        (Just mode)+        (Just window)+        FileChooserActionSave+        [("save",ResponseOk),("cancel",ResponseCancel)]+      fileChooserSetDoOverwriteConfirmation fileChooser True+      runFileChooser window area fileChooser mode inputB outputB+  return ()+  ++{-+TODO Refactor text to an 'link' to the entry text+for the ability to save files+Setups the menu+-}+create :: Window+  -> TextArea+  -> TextBuffer+  -> TextBuffer+  -> IO MenuBar+create window area output input= do+  menuBar <- menuBarNew-- container for menus++  menuFile <- menuNew+  menuHelp <- menuNew++  menuFileItem <- menuItemNewWithLabel "File"+  menuOpenItem <- menuItemNewWithLabel "open crtl+o"+  menuSaveItem <- menuItemNewWithLabel "save ctrl+s"+  menuCloseItem <- menuItemNewWithLabel "quit ctrl+s"+  menuCompileItem <- menuItemNewWithLabel "compile ctrl+shift+F5"+  menuCompileAndRunItem <- menuItemNewWithLabel "compile and run ctrl+F5"+  menuHelpItem <- menuItemNewWithLabel "Help"+  menuAboutItem <- menuItemNewWithLabel "About"+  --Bind the subemenu to menu+  menuItemSetSubmenu menuFileItem menuFile+  menuItemSetSubmenu menuHelpItem menuHelp+  --File and Help menu+  menuShellAppend menuBar menuFileItem+  menuShellAppend menuBar menuHelpItem+  --Insert items in menus+  menuShellAppend menuFile menuOpenItem+  menuShellAppend menuFile menuSaveItem+  menuShellAppend menuFile menuCloseItem+  menuShellAppend menuFile menuCompileItem+  menuShellAppend menuFile menuCompileAndRunItem+  menuShellAppend menuHelp menuAboutItem+  --setting actions for the menu+  on menuOpenItem menuItemActivate (fileDialog +    window +    area+    "OpenFile"+    input+    output+    )+  on menuSaveItem menuItemActivate $ void (saveFile+    window+    area+    input+    output)+  on menuCloseItem menuItemActivate mainQuit+  on menuCompileItem menuItemActivate $+    void (compileOpenFile window output input)+  on menuCompileAndRunItem menuItemActivate $ compileAndRun window output input+    +  --setting shortcuts in relation to menuBar+  on window keyPressEvent $ do+    modi <- eventModifier+    key <- eventKeyName+    liftIO $ case modi of+      [Control] -> case key of+        "q" -> mainQuit >> return True+        "s" -> saveFile window area input output >> return True+        "o" -> fileDialog+          window+          area+          "OpenFile"+          input+          output >> return True+        "F5" -> compileAndRun window output input >> return True+        _ -> return False+      [Shift,Control] -> case key of+        "F5" -> compileOpenFile window output input >> return True+        _ -> return False+      _ -> return False+  return menuBar++-- | It compiles and interprets the rail source.+-- Using inputbuffer for input and outputbuffer for programm output+compileAndRun :: Window+  -> TextBuffer+  -> TextBuffer +  -> IO ()+compileAndRun window output input = do+  (exeName,msg) <- compileOpenFile window output input+  inP <- get input textBufferText+  (exitCode,out,err) <- EXE.executeRail exeName inP+  textBufferSetText output +    (if exitCode == ExitSuccess then out else msg++"\n"++out++"\n"++err)++-- | This Function invokes the compilation and linking of the open rail source.+-- It also puts stdout and sterr from linking and compiling to bufferOut.+compileOpenFile ::Window+  -> TextBuffer+  -> TextBuffer +  -> IO (String,String) --name of linked file and msg from compiler and llvm-link+compileOpenFile window output input = do+  path <- get window windowTitle+  let compiledPath = (takeWhile(/='.').reverse.takeWhile(/='/').reverse)path++".ll"+  textBufferSetText output "Compiling Execute"+  (exitCode,out,err) <- EXE.compile path compiledPath+  if exitCode == ExitSuccess+  then do+    let exeName = takeWhile (/='.') compiledPath+    textBufferSetText output "Compiling succsessful"+    (exitCode,out,err) <- EXE.linkLlvm compiledPath exeName+    if exitCode == ExitSuccess+    then do+      let msg = "Compiling succsessful\n"++out++"\n"++err+      textBufferSetText output msg+      return (exeName,msg)+    else do+      let msg = "llvm-link failed:\n"++out++"\n"++err+      textBufferSetText output msg+      return (exeName,msg)+  else do +    let msg = "Compiling failed: "++"\n"++out++err+    textBufferSetText output msg+    return ("",msg)++
+ src/RailEditor/RedoUndo.hs view
@@ -0,0 +1,112 @@+{- |+Module      :  RedoUndo.hs+Description :  .+Maintainer  :  Christian H. et al.+License     :  MIT++Stability   :  experimental++The RedoUndo-module contains three functions that allow to redo- and undo-actions in the editor.+-}+module RedoUndo (+                 action,-- something was done in the editor+                 undo,  -- allows to undo actions in the editor+                 redo   -- allows to redo actions in the editor+                )+  where+    +    -- imports --+    import Data.IORef+    import Control.Monad+    import qualified TextAreaContent as TAC+    import qualified TextAreaContentUtils as TACU+    +    data UndoRedo = Undo | Redo deriving Eq++    -- functions --+    invert :: (TAC.Action, TAC.Position) -> (TAC.Action, TAC.Position)+    invert a@(TAC.DoNothing, pos) = a+    invert (TAC.Concat act1 act2, pos) = (TAC.Concat (invert act1) (invert act2), pos)+    invert (TAC.Remove content, pos) = (TAC.Insert content, pos)+    invert (TAC.Insert content, pos) = (TAC.Remove content, pos)+    invert (TAC.Replace a b, pos) = (TAC.Replace b a, pos)+    invert (TAC.RemoveLine, (x, y)) = (TAC.InsertLine, (x, y-1))+    invert (TAC.InsertLine, (x, y)) = (TAC.RemoveLine, (x, y+1))++    -- add a given function to our queues+    action :: TAC.TextAreaContent -> TAC.Position -> TAC.Action -> IO ()+    action tac position useraction = do+      redoqueue <- readIORef (TAC.redoQueue tac)+      unless (null redoqueue) $ writeIORef (TAC.redoQueue tac) []+      undoqueue <- readIORef (TAC.undoQueue tac)+      writeIORef (TAC.undoQueue tac) (invert (useraction, position):undoqueue)++    -- gets the action to to and move it from one queue to the opposite one+    shiftaction :: (TAC.ActionQueue, TAC.ActionQueue) -> (TAC.ActionQueue, TAC.ActionQueue, (TAC.Action, TAC.Position))+    shiftaction (from, to) = (tail from, invert (head from):to, head from)++    -- run whatever action given+    runaction :: TAC.TextAreaContent -> (TAC.Action, TAC.Position) -> IO TAC.Position+    runaction _ (TAC.DoNothing, actpos) = return actpos+    runaction tac (TAC.Concat act1 act2, actpos) =+      runaction tac act1 >> runaction tac act2+    runaction tac (TAC.Remove [], actpos) = return actpos+    runaction tac (TAC.Remove (x:xs), actpos) = do+      TAC.deleteCell tac actpos+      TACU.moveChars tac actpos (-1,0)+      runaction tac (TAC.Remove xs, actpos)+    runaction tac (TAC.Insert [], actpos) = return actpos+    runaction tac (TAC.Insert (content@(char,_):xs), actpos) = do+      if char == '\n'+      then TACU.moveLinesDownXShift tac actpos True+      else do+        TACU.moveChars tac actpos (1,0)+        TAC.putCell tac actpos (content, TAC.defaultColor)+      runaction tac (TAC.Insert xs, actpos)+    runaction tac (TAC.Replace a [], actpos) = return actpos+    runaction tac (TAC.Replace a (content@(char,_):xs), actpos@(px, py)) =+      if char == ' '+      then runaction tac (TAC.Remove [content], actpos)+      else do+        TAC.putCell tac actpos (content, TAC.defaultColor)+        runaction tac (TAC.Replace a xs, (px+1, py))+    runaction tac (TAC.RemoveLine, (x, y)) = do+      TACU.moveLinesUp tac y+      return (x, y-1)+    runaction tac (TAC.InsertLine, (x, y)) = do+      TACU.moveLinesDownXShift tac (x, y) True+      return (0, y+1)++    -- allows to undo actions in the editor+    undo :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position+    undo tac pos = do+      undoqueue <- readIORef (TAC.undoQueue tac)+      if not (null undoqueue)+      then runRedoUndo tac Undo+      else return pos++    -- allows to redo actions in the editor+    redo :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position+    redo tac pos = do+      redoqueue <- readIORef (TAC.redoQueue tac)+      if not (null redoqueue)+      then runRedoUndo tac Redo+      else return pos++    runRedoUndo :: TAC.TextAreaContent -> UndoRedo -> IO TAC.Position+    runRedoUndo tac cmd = do+      redoqueue <- readIORef (TAC.redoQueue tac)+      undoqueue <- readIORef (TAC.undoQueue tac)+      if cmd == Undo then do+        let (newundo, newredo, action) = shiftaction (undoqueue, redoqueue)+        exec tac newundo newredo action+      else do+        let (newredo, newundo, action) = shiftaction (redoqueue, undoqueue) +        exec tac newundo newredo action+     +    exec :: TAC.TextAreaContent -> TAC.ActionQueue -> TAC.ActionQueue -> (TAC.Action,TAC.Position) -> IO TAC.Position+    exec tac u r action = do+      writeIORef (TAC.redoQueue tac) r+      writeIORef (TAC.undoQueue tac) u+      runaction tac action+
+ src/RailEditor/Selection.hs view
@@ -0,0 +1,208 @@+{- |+Module      :  Selection.hs+Description :  .+Maintainer  :  Benjamin Kodera (c)+License     :  MIT++Stability   :  stable++The Selection-module handles multiple character selection as well as copy and paste functionality.+-}++module Selection (+                    handleSelection,+                    updateCells,+                    relocateCells,+                    clear,+                    getFirstPositions,+                    getBottomRight,+                    getMinimum,+                    pasteReplace,+                    pasteInsert,+                    getCellsByPositons,+                    deselect+                 )+  where++import qualified Data.Map as Map+import Data.IORef+import Control.Monad+import Data.Maybe+import qualified TextAreaContent as TAC+import qualified TextAreaContentUtils as TACU+import qualified Data.List as List+import qualified RedoUndo as History++handleSelection :: TAC.TextAreaContent -> TAC.Position -> TAC.Position -> IO (Bool,[TAC.Position])+handleSelection tac currentPos newPos = do+  positions <- TAC.getPositons tac+  let selectedEntries = getSelectedEntries positions currentPos newPos+  if not (null selectedEntries) then do+    cell <- TAC.getCell tac $ head selectedEntries+    let isAlreadySelected = snd $ fst $ fromJust cell+    updateCells tac selectedEntries $ not isAlreadySelected +    return (isAlreadySelected,selectedEntries)+  else return (False,[])+  +updateCells :: TAC.TextAreaContent -> [TAC.Position] -> Bool -> IO TAC.Position+updateCells tac positions value = do +  _updateCells tac positions value+  return $ getBottomRight positions+  +_updateCells :: TAC.TextAreaContent -> [TAC.Position] -> Bool -> IO ()+_updateCells _ [] _ = return ()+_updateCells tac (pos:xs) value = do+  updateCell tac pos value+  _updateCells tac xs value  +  +updateCell :: TAC.TextAreaContent -> TAC.Position -> Bool -> IO ()  +updateCell tac pos value = do+  cell <- TAC.getCell tac pos+  when (isJust cell) $ do+    let ((char,_),color) = fromJust cell+    TAC.deleteCell tac pos+    TAC.putCell tac pos ((char,value),color)++relocateCells :: TAC.TextAreaContent -> [(TAC.Position,(Char,Bool))] -> TAC.Position -> IO TAC.Position+relocateCells tac [] pos = return pos+relocateCells tac content (x,y) = do+  let (positions,cells) = List.unzip content+      (x1,y1) = getMinimum positions+      (x2,y2) = getBottomRight positions+  _relocateCells tac positions (List.map fst cells) (x,y) (x1,y1)+  return (x+x2-x1,y+y2-y1)++_relocateCells :: TAC.TextAreaContent -> [TAC.Position] -> String -> TAC.Position -> TAC.Position -> IO ()+_relocateCells _ [] _ _ _ = return ()+_relocateCells tac (position:positions) (char:chars) newPos offset = do+  relocateCell tac position char newPos offset+  _relocateCells tac positions chars newPos offset+  +relocateCell :: TAC.TextAreaContent -> TAC.Position -> Char -> TAC.Position -> TAC.Position -> IO ()  +relocateCell tac pos@(x,y) char (newX,newY) (offsetX,offsetY) =+  TAC.putCell tac (newX+x-offsetX,newY+y-offsetY) ((char,False),TAC.defaultColor)++-- | clears a selection and removes all selected characters+clear :: TAC.TextAreaContent -> TAC.Position -> IO (TAC.Position,TAC.Position)+clear tac pos@(x,y) = do+  positions <- TAC.getSelectedPositons tac+  if not (null positions) then do+    cells <- Selection.getCellsByPositons tac positions+    History.action tac (getMinimum positions) (TAC.Remove cells)+    clearCells tac positions+    return (getMinimum positions,getMaximum positions)+  else return ((x-1,y),(x-1,y))++clearCells :: TAC.TextAreaContent -> [TAC.Position] -> IO ()+clearCells tac [] = return ()+clearCells tac (x:xs) = do+  TAC.deleteCell tac x+  clearCells tac xs++getCellsByPositons :: TAC.TextAreaContent -> [TAC.Position] -> IO [(Char,Bool)]+getCellsByPositons _ [] = return []+getCellsByPositons tac positions = _getCellsByPositons tac positions []++_getCellsByPositons :: TAC.TextAreaContent -> [TAC.Position] -> [(Char,Bool)] -> IO [(Char,Bool)]+_getCellsByPositons _ [] cells = return cells+_getCellsByPositons tac (x:xs) cells = do+  cell <- TAC.getCell tac x +  if isJust cell then do +    let (content,_) = fromJust cell+    _getCellsByPositons tac xs (content:cells)+  else _getCellsByPositons tac xs cells++getSelectedEntries :: [TAC.Position] -> TAC.Position -> TAC.Position -> [TAC.Position]+getSelectedEntries positions (x1,y1) (x2,y2)+  -- down+  | y2 > y1 = List.filter (\(x,y) -> x >= x1 && y == y1 || y > y1 && y < y2 || x < x2 && y == y2) positions+  -- right+  | x2 > x1 && y2 == y1 = List.filter (\(x,y) -> x >= x1 && x < x2 && y == y2) positions +  -- left+  | x2 < x1 && y2 == y1 = List.filter (\(x,y) -> x < x1 && x >= x2 && y == y2) positions +  -- up+  | otherwise = List.filter (\(x,y) -> x < x1 && y == y1 || y < y1 && y > y2 || x >= x2 && y == y2) positions++getMaximumY :: [TAC.Position] -> TAC.Coord+getMaximumY = Prelude.foldl (\y1 (_,y2) -> max y1 y2) 0++getMaximumX :: [TAC.Position] -> TAC.Coord+getMaximumX = Prelude.foldl (\x1 (x2,_) -> max x1 x2) 0++getMinimumY :: [TAC.Position] -> TAC.Coord+getMinimumY [] = 0+getMinimumY positions = fst $ minimum $ Prelude.map (\(x,y) -> (y,x)) positions++getMinimumX :: [TAC.Position] -> TAC.Coord+getMinimumX [] = 0+getMinimumX positions = fst $ minimum positions++getTopLeft :: [TAC.Position] -> TAC.Position+getTopLeft [] = (0,0)+getTopLeft positions = (getMinimumX positions, getMinimumY positions)++getBottomRight :: [TAC.Position] -> TAC.Position+getBottomRight [] = (0,0)+getBottomRight positions = (x+1,y)+  where (y,x) = maximum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions+  +getMinimum :: [TAC.Position] -> TAC.Position+getMinimum [] = (0,0)+getMinimum positions = (x,y) +  where (y,x) = minimum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions++getMaximum :: [TAC.Position] -> TAC.Position+getMaximum [] = (0,0)+getMaximum positions = (x,y) +  where (y,x) = maximum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions++getFirstPositions :: [TAC.Position] -> [TAC.Position]+getFirstPositions [] = []+getFirstPositions positions = List.map minimum $ List.groupBy (\(x1,y1) (x2,y2) -> y1 == y2) positions++paste :: TAC.TextAreaContent -> TAC.Position -> Bool -> IO TAC.Position+paste tac pos replace = do+  clipboard <- TAC.getClipboard tac+  let (clipboardPositions,cells) = List.unzip clipboard+  when replace $ shiftSubsequentLines tac pos clipboardPositions+  History.action tac pos (TAC.Insert cells)+  selectedPositions <- TAC.getSelectedPositons tac+  newPos <- relocateCells tac clipboard $+    if not (null selectedPositions)+    then getMinimum selectedPositions+    else pos+  clear tac newPos+  return newPos++-- | pastes content from clipboard to position in override mode+pasteReplace :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position+pasteReplace tac pos = paste tac pos True++-- | pastes content from clipboard to position in insert mode+pasteInsert :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position+pasteInsert tac pos = paste tac pos False++shiftSubsequentLines :: TAC.TextAreaContent -> TAC.Position -> [TAC.Position] -> IO ()+shiftSubsequentLines tac pos clipboardPositions = do+  let (x1,y1) = getMinimum clipboardPositions+      (x2,y2) = getMaximum clipboardPositions+      (xShift,yShift) = (abs (x1-x2), abs (y1-y2))+  positionsToShiftDown <- TAC.getPositonsFrom tac pos+  shiftDownLines tac positionsToShiftDown yShift    +  TACU.moveChars tac pos (xShift+1,yShift)    ++shiftDownLines :: TAC.TextAreaContent -> [TAC.Position] -> TAC.Coord -> IO ()+shiftDownLines tac positionsToShiftDown yShift = do+  let firsts = getFirstPositions positionsToShiftDown+  _shiftDownLines tac firsts yShift+  +_shiftDownLines tac [] _ = return ()+_shiftDownLines _ _ 0 = return ()+_shiftDownLines tac (x:xs) shift = do+  _shiftDownLines tac xs shift+  TACU.moveChars tac x (0,shift)++deselect :: TAC.TextAreaContent -> IO TAC.Position+deselect tac = do+  selectedPositions <- TAC.getSelectedPositons tac+  updateCells tac selectedPositions False
src/RailEditor/TextArea.hs view
@@ -1,614 +1,411 @@-module TextArea where+{- |+Module      :  TextArea.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT+Stability   :  experimental -import Lexer-import Preprocessor as Pre-import InterfaceDT as IDT-import Graphics.UI.Gtk-import Data.Map as Map-import Control.Monad.Trans (liftIO)-import qualified Control.Exception as Exc-import System.IO-import Data.IORef-import Data.Maybe-import Data.Either+The TextArea-module depicts the view on the data structure stored in the TextAreaContent-module for the editor.+-} -data EntryMode = LeftToRight | UpToDown | Smart deriving (Eq)---textArea is a pointer to: -data TextArea = TextArea -  Layout -  (IORef (Int,Int)) --pointer to current selected entry-  (IORef (Map.Map (Int,Int) Entry)) {-pointer to hashmap of entrys with -  (x,y) coords as key starting by (0,0)-}-  (IORef (Int,Int)) --pointer to the  size of the textArea ---returns the layout-getLayout (TextArea layout _ _ _) = layout+module TextArea( ---returns a point to the current selected entry-getPointerToCurrentInFocus (TextArea _ current _ _) = current+-- * Types+  TextArea,+-- * Constructors+  initTextAreaWithContent,+-- * Constants+-- * Methods+  textAreaContent,+  currentPosition,+  setTextAreaContent,+  drawingArea,+  getTextAreaContainer, -- This function should be used to get a widget to place in MainWindow+  setInputMode,+  setHighlighting,+  redrawContent+  )where+    +    -- imports --+import qualified TextAreaContent as TAC+import qualified KeyHandler+import qualified Highlighter as HIGH+import qualified Selection ---returns a pointer to hashmap of entrys-getPointerToEntryMap (TextArea _ _ map _) = map---returns a pointer to the textArea size-getPointerToSize (TextArea _ _ _ size) = size+import qualified Graphics.Rendering.Cairo as CAIRO+import qualified Graphics.UI.Gtk as GTK+import qualified Graphics.UI.Gtk.Gdk.Events as Events+import Control.Concurrent (threadDelay)+import Data.IORef as IORef+import Data.Maybe+import qualified Data.Map as Map+import Control.Monad+import qualified Graphics.UI.Gtk.Gdk.GC as GC ---returns the grid2D from a IDT.IPL grid2D-getGrid2dFromPreProc2Lexer(IDT.IPL grid2D) = grid2D+{-+  This is the main datatype of TextArea +-}+data TextArea = TA { drawingArea :: GTK.DrawingArea,+    textAreaContent :: IORef TAC.TextAreaContent, --The TAC+    scrolledWindow :: GTK.ScrolledWindow, --The part to bind it in a container+    currentPosition :: IORef TAC.Position, --The current position of cursor without hef and bef+    vAdjustment :: GTK.Adjustment, --needed to create a scrolledWindow+    hAdjustment :: GTK.Adjustment, --needed to create a scrolledWindow+    inputMode :: IORef KeyHandler.InputMode, -- needed to set and get the current input mode+    getHighlighted :: IORef Bool} -- needed to determine, whether the area is highlighted --- creates a new textArea-textAreaNew :: Layout  -- the layout which entrys would be placed on-  -> Int --number of entrys in width-  -> Int --numer of entry in height-  -> IO TextArea --A textArea ready for writing-textAreaNew layout x y = do-  currentInFocus <- newIORef (0,0)-  hashMap <- newIORef Map.empty-  size <- newIORef (0,0)-  let area =  TextArea layout currentInFocus hashMap size-  createTextArea area x y-  return area+--The cursor color+defaultCursorColor :: GC.Color+defaultCursorColor = GC.Color 65535 0 0  ---Subfunction of textAreaNew which invokes the entry-creation-createTextArea :: TextArea --the empty textArea-  -> Int --number of entrys in width-  -> Int --numer of entry in height-  -> IO()-createTextArea area@(TextArea layout current hmap size) x y = do-  createTextAreaH area 0 (pred x) 0 (pred y)-  writeIORef size (x-1,y-1)-  return ()+--The background color+defaultBgColor :: GC.Color+defaultBgColor = GC.Color 65535 65535 65535 ---Subfunction of createTextArea. This fct creates the lines of textArea-createTextAreaH :: TextArea-  -> Int--current x coord in textArea-  -> Int--max x coord in textArea-  -> Int--current y coord in textArea-  -> Int--max y coord in textArea-  -> IO()-createTextAreaH area@(TextArea _ _ _ size) xnr xnrS ynr ynrS = do-  (maxX,maxY) <- readIORef size-  if xnr == xnrS && ynr == ynrS-  then entryInsert area xnrS xnrS-  else if xnr == xnrS && ynr < ynrS-  then do-    entryInsert area  xnr ynr--inserts the textEntry-    createTextAreaH area 0 xnrS (succ ynr) ynrS-  else do-    entryInsert area xnr ynr--inserts the textEntry-    createTextAreaH area (succ xnr) xnrS ynr ynrS+bef = 15 :: TAC.Coord --width of a character+hef = 15 :: TAC.Coord --height of a character ---function to react on a "Return" keypress-handleReturn area@(TextArea layout current hMap size)x y = do-  hmap <- readIORef hMap-  let nextEntry = Map.lookup (0,y+1) hmap-  if isNothing nextEntry-  then do-    (xm,ym) <- readIORef size-    expandYTextArea area xm ym-    hmap <- readIORef hMap-    let nEntry = fromJust $ Map.lookup (0,y+1) hmap-    widgetGrabFocus nEntry-    return True-  else do-    let nEntry = fromJust nextEntry-    widgetGrabFocus nEntry-    return True+width = 400+height = 600 ---function to react on a "Left-Arrow" keypress-handleLeft area@(TextArea layout current hMap size)x y = do-  hmap <- readIORef hMap-  let prevEntry = Map.lookup (x-1,y) hmap-  if isJust prevEntry-  then do-    widgetGrabFocus (fromJust prevEntry)-    return True-  else do-    (xm,ym) <- readIORef size-    if y>0-    then do-      widgetGrabFocus $ fromJust $ Map.lookup (xm, y-1) hmap-      return True-    else return False+{-+  This function returns a scrolled Window which can be used+  to bind it on a widget.+-}+getTextAreaContainer :: TextArea -> IO GTK.ScrolledWindow+getTextAreaContainer textArea = return $ scrolledWindow textArea ---function to react on a "Right-Arrow" keypress-handleRight area@(TextArea layout current hMap size)x y = do-  hmap <- readIORef hMap-  let nextEntry = Map.lookup (x+1,y) hmap-  if isJust nextEntry-  then do-    widgetGrabFocus $ fromJust nextEntry-    return True+setInputMode :: TextArea -> KeyHandler.InputMode -> IO ()+setInputMode area mode = do+  let modeRef = inputMode area+  writeIORef modeRef mode++{-+  This function sets the TextArea TAC to the TAC given in argument 2.+-}+setTextAreaContent :: TextArea -> TAC.TextAreaContent -> IO ()+setTextAreaContent textArea areaContent= do+  let +    areaRef = textAreaContent textArea+    drawArea = drawingArea textArea+    highlightedIORef = getHighlighted textArea+  writeIORef areaRef areaContent+  highlighted <- readIORef highlightedIORef+  --expand the drawWindow when needed+  tac <- readIORef areaRef+  s@(xMax,yMax) <- TAC.size tac+  (w,h) <- GTK.widgetGetSizeRequest drawArea+  if yMax*hef > h && xMax*bef > w+  then GTK.widgetSetSizeRequest drawArea (w + (xMax*bef-w)) (h+(yMax*hef-w))   else do-    (xm,ym) <- readIORef size-    if y<ym-    then do-      widgetGrabFocus $ fromJust $ Map.lookup (0, y+1) hmap-      return True-    else return False+    when (yMax*hef > h ) $+      GTK.widgetSetSizeRequest drawArea w (h+((yMax*hef)-w))+    when (xMax*bef > w) $+      GTK.widgetSetSizeRequest drawArea (w + (xMax*bef-w))  h+  when highlighted $ HIGH.highlight tac+  redrawContent textArea ---function to react on a "Up-Arrow" keypress-handleUp area@(TextArea layout current hMap size) x y = do-  hmap <- readIORef hMap-  let nextEntry = Map.lookup (x,y-1) hmap-  if isJust nextEntry-  then do-    widgetGrabFocus $ fromJust nextEntry-    return True-  else return False+-- | sets (True) or unsets (False) the highlighting +setHighlighting :: TextArea -> Bool -> IO ()+setHighlighting area val = do+  writeIORef (getHighlighted area) val+  tac <- readIORef $ textAreaContent area+  if val+  then HIGH.highlight tac+  else TAC.deleteColors tac+  redrawContent area ---function to react on a "Down-Arrow" keypress-handleDown area@(TextArea layout current hMap size) x y = do-  hmap <- readIORef hMap-  let nextEntry = Map.lookup (x,y+1) hmap-  if isJust nextEntry-  then do-    widgetGrabFocus $ fromJust nextEntry-    return True-  else return False+{-+  This function setup the TextArea. It Set up the drawWindow +  related to textAreaContent. It also setup the different user events+  for editing the TextArea+-}+initTextAreaWithContent :: TAC.TextAreaContent -> IO TextArea+initTextAreaWithContent areaContent = do+  veAdjustment <- GTK.adjustmentNew 0 0 0 (fromIntegral hef) 0 0+  hoAdjustment <- GTK.adjustmentNew 0 0 0 (fromIntegral bef) 0 0+  scrwin <- GTK.scrolledWindowNew (Just hoAdjustment) (Just veAdjustment)+  areaRef <- newIORef areaContent+  drawArea <- setUpDrawingArea+  GTK.scrolledWindowAddWithViewport scrwin drawArea+  posRef <- newIORef (0,0)+  modRef <- newIORef KeyHandler.Insert+  highlighted <- newIORef True+  let textArea = TA drawArea areaRef scrwin posRef veAdjustment hoAdjustment modRef highlighted ---function to react on a "Tab" keypress-handleTab area@(TextArea layout current hMap size)x y = do-  hmap <- readIORef hMap-  let nextEntry = Map.lookup (x+4,y) hmap-  if isNothing nextEntry-  then do-    (xm,ym) <- readIORef size-    expandXTextAreaN area xm ym 4-    hmap <- readIORef hMap-    let nEntry = fromJust $ Map.lookup (x+4,y) hmap-    widgetGrabFocus nEntry-    return True-  else do-    let nEntry = fromJust nextEntry-    widgetGrabFocus nEntry+  {-This function is called when the user press a mouse button.+    It calls the handleButtonPress function.  +  -}+  GTK.onButtonPress drawArea $ \event -> do+    let posRef = currentPosition textArea+    GTK.widgetGrabFocus drawArea+    readIORef posRef >>= clearCursor textArea+    handleButtonPress textArea (round(Events.eventX event),round(Events.eventY event)) >>= writeIORef posRef+    return $ Events.eventSent event+    +  GTK.on drawArea GTK.motionNotifyEvent $ do+    actualPos <- GTK.eventCoordinates+    CAIRO.liftIO $ do+      let areaRef = textAreaContent textArea+      tac <- readIORef areaRef+      currentPos <- readIORef posRef                            +      newPos <- updatePosition actualPos+      clearCursor textArea currentPos+      showCursor textArea newPos+      when (currentPos /= newPos) $ do+        (isAlreadySelected,selectedContent) <- Selection.handleSelection tac currentPos newPos+        if isAlreadySelected +        then deselectEntries textArea tac selectedContent+        else selectEntries textArea selectedContent+        writeIORef posRef newPos+    GTK.eventRequestMotions     return True+  {-+    This function is called when the user presses a key.+    It starts the heyHandler the highlighter and redraw the textAreaContent.+  -}+  GTK.onKeyPress drawArea $ \event -> do+    let +      posRef   = currentPosition textArea+      areaRef  = textAreaContent textArea+      modif = Events.eventModifier event+      key = Events.eventKeyName event+      val = Events.eventKeyVal event+      modRef = inputMode textArea+    modus <- readIORef modRef+    tac <- readIORef areaRef --TextAreaContent+    readIORef posRef >>= clearCursor textArea+    posBef@(x,y) <- readIORef posRef+    pos@(kx,ky) <- KeyHandler.handleKey tac posBef modus modif key val+    --expand the drawWindow when needed+    extendDrawingAreaHorizontally textArea kx+    extendDrawingAreaVertically textArea ky+    writeIORef posRef pos+    highlighted <- readIORef (getHighlighted textArea)+    when highlighted $ HIGH.highlight tac+    redrawContent textArea+    showCursor textArea pos+    return $ Events.eventSent event+ +  {-+    Called when the application starts+    It setting the cursor and draw the textAreaContent+  -}+  GTK.onExpose drawArea $ \(Events.Expose sent _ _ _) -> do+    let +      posRef   = currentPosition textArea+      areaRef  = textAreaContent textArea+    content <- readIORef areaRef+    redrawContent textArea+    readIORef posRef >>= showCursor textArea+    return sent+  return textArea ---function to react on a "Backspace" keypress    -handleBackspace area@(TextArea layout current hMap size) entry x y = do-  hmap <- readIORef hMap-  let prevEntry = Map.lookup (x-1,y) hmap-  thisChar <- entryGetText entry-  if thisChar /= ""-  then do-    set entry [entryText := ""]-    return False-  else-    if isJust prevEntry-    then do-      entrySetText (fromJust prevEntry) ""-      widgetGrabFocus (fromJust prevEntry)-      return True-    else do-      (xm,ym) <- readIORef size-      if y>0-      then do-        widgetGrabFocus $ fromJust $ Map.lookup (xm, y-1) hmap-        return True-      else return False ---Inserts a new entry to the textArea and sets up its keypressHandler-entryInsert :: TextArea-  -> Int --x coord to insert-  -> Int --y coord to insert-  -> IO()-entryInsert area@(TextArea layout current hMap size) x y = do-  --creation and config and insert-  entry <- entryNew-  set entry [entryWidthChars := 1, entryText := " "]-  entrySetMaxLength entry 1-  entrySetHasFrame entry False-  layoutPut layout entry (x*12) (18*y+20)-  hamp <- readIORef hMap-  let hMapN = Map.insert (x,y) entry hamp-  writeIORef hMap hMapN-  --Handler setup-  entry `on` focusInEvent $ tryEvent $ liftIO $ writeIORef current (x,y)-  --KeyEventHandler gets a anonymus function-  on entry keyPressEvent $ do -    key <- eventKeyName-    val <- eventKeyVal-    liftIO $ do-      --Just keyhandling and expanding the entry if full-      if isJust (keyToChar val)-      then do-        set entry [entryText := (-          if isNothing (keyToChar val)-          then "" -          else [fromJust $ keyToChar val])]-        hmap <- readIORef hMap-        let nextEntry = Map.lookup (x+1,y) hmap-        if isNothing nextEntry-        then do-          (xm,ym) <- readIORef size-          expandXTextArea area xm ym-          hmap <- readIORef hMap-          let nEntry = fromJust $ Map.lookup (x+1,y) hmap-          widgetGrabFocus nEntry-          return True-        else do-          let nEntry = fromJust nextEntry-          widgetGrabFocus nEntry-          return True-        else case key of-          "Return" -> handleReturn area x y-          "Left" -> handleLeft area x y-          "Right" -> handleRight area x y-          "Tab" -> handleTab area x y-          "BackSpace" -> handleBackspace area entry x y-          "Up" -> handleUp area x y-          "Down" -> handleDown area x y-          _ -> return False-      --Syntaxhighlighting starts here-      syntaxHighlighting area-      return True   -  return ()----Handler to catch errors from Preprocessor.hs-handler :: Exc.ErrorCall -> IO ()-handler _ = putStrLn "No main function"--syntaxHighlighting area@(TextArea layout current hMap size) = do-  (code,indexes) <- serializeIt area (0,0) ("",[])-  Exc.catch (do-    let grid2D = getGrid2dFromPreProc2Lexer $ Pre.process  (IIP code)-    (xm,ym) <- readIORef size-    paintItRed area 0 0 xm ym-    changeColorOfCurrentEntry area (Color 65535 0 0)-    --print"new Lexerturn"-    highlightFcts area grid2D indexes -    return ()) handler---- this is needed to clear the textArea-clearTextArea area = do-    hmap <- readIORef $ getPointerToEntryMap area-    let list = toList hmap-    mapM_ (\(_,entry) -> set entry [entryText := ""]) list-    return ()---- maps string to textArea content-deserializeTextArea area string = do-    clearTextArea area-    expandTextAreaTo area newX newY-    readStringListInEntryMap (getPointerToEntryMap area) lined (0,0)-    where newX = maximum $ Prelude.map length lined-          newY = length lined-          lined = lines string---- help function for deserialization-readStringListInEntryMap _ [] _ = return ()-readStringListInEntryMap hmap (e:es) (x,y) = do-    readStringInEntryMap hmap e (0,y)-    readStringListInEntryMap hmap es (0,(y+1));---- help function for deserialization-readStringInEntryMap _ [] _ = return ()-readStringInEntryMap hmap (s:ss) (x,y) = do-    entryMap <- readIORef hmap-    let entry = fromJust $ Map.lookup (x,y) entryMap-    set entry [entryText := [s]]-    readStringInEntryMap hmap ss (succ x,y)---- this is needed to expand the textArea to x y-expandTextAreaTo area newX newY = do-    let sizePtr = getPointerToSize area-    (x,y) <- readIORef sizePtr-    let xDelta = newX-x-    let yDelta = newY-y-    expandXTextAreaN area x y xDelta-    expandYTextAreaN area x y yDelta----this is needed to expand the textArea in y n times(#line times) -expandYTextAreaN area oldX oldY n-  | n <= 0 = return ()-  | otherwise = do-    expandYTextArea area oldX oldY-    expandYTextAreaN area oldX (succ oldY) (n-1)+{-+  This function setup the DrawArea using GTK.DrawingArea.+-}+setUpDrawingArea :: IO GTK.DrawingArea+setUpDrawingArea = do+  drawingArea <- GTK.drawingAreaNew+  GTK.widgetModifyBg drawingArea GTK.StateNormal defaultBgColor+  GTK.set drawingArea [GTK.widgetCanFocus GTK.:= True]+  GTK.widgetAddEvents drawingArea [GTK.ButtonMotionMask]+  GTK.widgetSetSizeRequest drawingArea width height+  return drawingArea ---this is needed to expand the textArea in x n times(#line times) -expandXTextAreaN area oldX oldY n-  | n == 0 = return ()-  | otherwise = do-    expandXTextArea area oldX oldY-    expandXTextAreaN area (succ oldX) oldY (n-1)+--This handles a mouse button press event+handleButtonPress :: TextArea -> TAC.Position -> IO TAC.Position+handleButtonPress textArea (x,y) = do+  let tacIORef = textAreaContent textArea+      curPosIORef = currentPosition textArea+  showCursor textArea newPos+  tac <- readIORef tacIORef+  selection <- TAC.getSelectedPositons tac+  deselectEntries textArea tac selection+  Selection.updateCells tac selection False+  return newPos+  where newPos = (div x bef,div y hef)-- position without hef and bef ---Subfunction of expandXTextAreaN -expandXTextArea area@(TextArea layout current hMap size) oldX oldY= do-  expandXTextAreaH area oldX oldY-  (xmax,ymax) <- readIORef size-  writeIORef size (succ xmax,ymax)+{-+  This function renders a character at the given position.+  It calculate the coords for drawingArea from TAC.Position.+-} +renderScene :: TextArea -> TAC.Position -> Char -> TAC.RGBColor -> Bool -> Bool -> IO ()+renderScene textArea (x,y) char (TAC.RGBColor r g b) breakpoint isIP = do+  let drawArea = drawingArea textArea+  removeCharacter textArea (x,y)+  drawWindow <- GTK.widgetGetDrawWindow drawArea+  GTK.renderWithDrawable drawWindow $ do +    CAIRO.setSourceRGBA r g b 1.0+    CAIRO.moveTo (fromIntegral (xCoord x + 2)) (fromIntegral (yCoord y - 3))+    CAIRO.setFontSize 14+    CAIRO.showText [char]+  gc <- GC.gcNew drawWindow+  GC.gcSetValues gc $ GC.newGCValues { GC.foreground = defaultCursorColor }+  when breakpoint $ GTK.drawRectangle drawWindow gc False (xCoord x-2) (yCoord (y-1)) (bef-2) (hef-2)+  when isIP $ GTK.drawArc drawWindow gc False (xCoord x-2) (yCoord (y-1)) (bef-2) (hef-2) 0 23040 ---insert the new entrys at the end of a line-expandXTextAreaH area@(TextArea _ _ hMap _) oldX oldY = -  if oldY == 0-  then do-    entryInsert area (succ oldX) 0-    hmap <- readIORef hMap-    let newEntry = fromJust $ Map.lookup (succ oldX,oldY) hmap-    widgetShow newEntry-  else do-    entryInsert area (succ oldX) oldY-    hmap <- readIORef hMap-    let newEntry = fromJust $ Map.lookup (succ oldX,oldY) hmap-    widgetShow newEntry-    expandXTextAreaH area oldX (pred oldY)+--This function returns the y coord in relation to drawingArea    +yCoord :: TAC.Coord -> TAC.Coord+yCoord 0 = hef+yCoord y = y*hef + hef ---this is needed to expand the textArea in y (newline)-expandYTextArea area@(TextArea layout current hMap size) oldX oldY= do-  expandYTextAreaH area oldX oldY-  (xmax,ymax) <- readIORef size-  writeIORef size (xmax,succ ymax)+--This function returns the  coord in relation to drawingArea  +xCoord :: TAC.Coord -> TAC.Coord+xCoord x = x*bef+  +{-+  This Function removes the caracter at given position+  The function should be called in renderScene to avoid overwriting.+-}+removeCharacter :: TextArea -> TAC.Position -> IO ()     +removeCharacter textArea (x,y) = do+  let drawArea = drawingArea textArea+  drawWindow <- GTK.widgetGetDrawWindow drawArea+  GTK.drawWindowClearArea drawWindow (fromIntegral $ xCoord x) +          (fromIntegral(y*hef)) (fromIntegral bef) (fromIntegral hef)  ---Insert a new line-expandYTextAreaH area@(TextArea _ _ hMap _) oldX oldY = -  if oldX == 0-  then do-    entryInsert area 0 (succ oldY)-    hmap <- readIORef hMap-    let newEntry = fromJust $ Map.lookup (oldX,succ oldY) hmap-    widgetShow newEntry-  else do-    entryInsert area oldX (succ oldY)-    hmap <- readIORef hMap-    let newEntry = fromJust $ Map.lookup (oldX,succ oldY) hmap-    widgetShow newEntry-    expandYTextAreaH area (pred oldX) oldY+-- This Function draws every character in scrollable Frame.+redrawContent :: TextArea -> IO ()  +redrawContent textArea = do+  let +    tacIORef = textAreaContent textArea+    drawArea = drawingArea textArea+    vAdj = vAdjustment textArea +    hAdj = hAdjustment textArea+  vAdjValue <- GTK.adjustmentGetValue vAdj+  hAdjValue <- GTK.adjustmentGetValue hAdj+  drawFrameHeight <- GTK.adjustmentGetPageSize vAdj+  drawFrameWidth <- GTK.adjustmentGetPageSize hAdj+  drawWindow <- GTK.widgetGetDrawWindow drawArea+  s@(w,h) <- GTK.drawableGetSize drawWindow+  GTK.drawWindowClearArea drawWindow (round hAdjValue) (round vAdjValue) w h+  let +    xFrom = div (round hAdjValue) bef+    yFrom = div (round vAdjValue) hef+    xTo =  div (round hAdjValue + round drawFrameWidth) bef+    yTo = div (round vAdjValue + round drawFrameHeight) hef+  tac <- readIORef tacIORef+  --Function from Control.Monad Monad m => [a] -> (a -> m b) -> m ()+  forM_ [xFrom..xTo] (\x -> forM_ [yFrom..yTo] (\y -> draw textArea (x,y)))+  where+    -- Call renderScene to +    draw:: TextArea -> TAC.Position -> IO()+    draw textArea pos = do+      let tacIORef = textAreaContent textArea+      tac <- readIORef tacIORef+      mayCell <- TAC.getCell tac pos+      unless (isNothing mayCell) $ do +        let ((char,isSelected), color) = fromJust mayCell+        cnt <- readIORef (TAC.context tac)+        renderScene textArea pos char color (Map.findWithDefault False pos (TAC.breakMap cnt)) (pos == TAC.curIPPos cnt)+        when isSelected $ selectEntry textArea pos ---This overwrites the entry text with "" at (x,y)-clearEntryByCoord :: TextArea-  -> (Int,Int)--coord-  -> IO()-clearEntryByCoord (TextArea _ _ hMap _) (x,y) = do-  hashMap <- readIORef hMap-  let mayEntry = Map.lookup (x,y) hashMap-  if isJust mayEntry-  then do-    let entry = fromJust mayEntry-    set entry [entryText := ""]-  else return ()---This overwrites the current entry text with ""-clearCurrentEntry :: TextArea -> IO()-clearCurrentEntry (TextArea _ current hMap _) = do-  currentCoord <- readIORef current-  hashMap <- readIORef hMap-  let currentEntry = fromJust $ Map.lookup currentCoord hashMap-  set currentEntry [entryText := ""]+--Draws a cursor at the position.+--The function adds the TACU offsets+showCursor :: TextArea -> TAC.Position -> IO ()+showCursor textArea (x,y) = do+  let drawArea = drawingArea textArea+  drawWindow <- GTK.widgetGetDrawWindow drawArea+  gc <- GC.gcNew drawWindow+  GC.gcSetValues gc $ GC.newGCValues { GC.foreground = defaultCursorColor }+  GTK.drawRectangle drawWindow gc True (curX (x*bef)) (curY (y*hef)) 2 hef+  --http://hackage.haskell.org/package/gtk-0.12.5.7/docs/Graphics-UI-Gtk-Gdk-Drawable.html#t:Drawable+  return () ---changes the foreground color of the entry at (x,y) in textArea-changeColorOfEntryByCoord :: TextArea -  -> (Int,Int)--coord-  -> Color--r g b range from 0 (low -)to 65535 (highest intensity)-  -> IO()-changeColorOfEntryByCoord (TextArea _ _ hMap _) (x,y) color = do-  hashMap <- readIORef hMap-  let mayEntry = Map.lookup (x,y) hashMap-  if isJust mayEntry-  then do-    let entry = fromJust mayEntry-    widgetModifyText entry StateNormal color-  else return ()+-- delets the cursor at the given position.+clearCursor :: TextArea -> TAC.Position -> IO ()+clearCursor textArea (x,y) = do+  let drawArea = drawingArea textArea+  drawWindow <- GTK.widgetGetDrawWindow drawArea+  GTK.drawWindowClearArea drawWindow +    (fromIntegral (curX (x*bef))) +    (fromIntegral (curY (y*hef)))+    2+    (fromIntegral hef) ---changes the foreground color of the current entry in textArea-changeColorOfCurrentEntry :: TextArea -  -> Color--r g b range from 0 (low -)to 65535 (highest intensity)-  -> IO()-changeColorOfCurrentEntry (TextArea _ current hMap _) color = do-  currentCoord <- readIORef current-  hashMap <- readIORef hMap-  let currentEntry = fromJust $ Map.lookup currentCoord hashMap-  widgetModifyText currentEntry StateNormal color+--Coords for the cursor to fit the cells of characters+curX x = abs(x - mod x bef-1)+curY y = y - mod y hef --- colors all entry red in a rect from x,y to xMax,yMax--- This function is needed to recolor after editing-paintItRed :: TextArea -  -> Int-- x coord start-  -> Int--y coord str-  -> Int--x coord end-  -> Int--y coord end-  -> IO()-paintItRed textArea x y xMax yMax= do-  map <- readIORef $ getPointerToEntryMap textArea-  let entry = Map.lookup (x,y) map-  case entry of-    Nothing -> return ()-    _ ->-      if x == (xMax-1) && y == (yMax-1)-      then do-        widgetModifyText (fromJust entry) StateNormal red-        return ()-      else-        if x == (xMax-1)-        then do-          widgetModifyText (fromJust entry) StateNormal red-          paintItRed textArea 0 (y+1) xMax yMax-        else do-          widgetModifyText (fromJust entry) StateNormal red-          paintItRed textArea (x+1) y xMax yMax-  return ()-  where red = Color 65535 0 0-  --- highlight all rail-functions-highlightFcts :: TextArea-  -> [Grid2D]-- List of funtions in line-representation  -  -> [Int]-- start indexes of function(y coord of textArea) -  -> IO IP-highlightFcts area [] _ = return crash-highlightFcts area _ [] = return crash-highlightFcts area (x:xs) (y:ys) = do-  highlight area x start y-  highlightFcts area xs ys-  -{- to do different colors- main highlighting process which highlights a single rail-function.- Colors:-   comments : red-   $ : orange-   rails : black-   built in function blue-   constans green+{-+  This function extends the TextArea horizontal and set the scroll Frame.+  It should be called after KeyHandler  -}-highlight :: TextArea-  -> Grid2D-  -> IP-  -> Int-  -> IO IP-highlight _ [] _ _ = return crash-highlight textArea grid2D ip yOffset = do-  print "step"-  print $ show ip-  case ip == crash of-   True -> return ip-   _ -> do-    (lex, parseIP)<- return $ parse grid2D ip-    print "parsedIp"-    print (show parseIP)-    case lex of-      Just NOP              -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Boom             -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just EOF              -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Input            -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Output           -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just IDT.Underflow    -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just RType            -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just (Constant str)    -> do-        if [(current grid2D parseIP)] == "]" || -          [(current grid2D parseIP)] == "["-        then do-          colorMoves textArea grid2D (length str+2)-            (turnaround parseIP) green-          highlight textArea grid2D (step grid2D parseIP)yOffset-        else do-          changeColorOfEntryByCoord textArea (xC,yC) green-          highlight textArea grid2D (step grid2D parseIP)yOffset-       -        return ()-      Just (Push str)-> do-        colorMoves textArea grid2D (length str+2)-          (turnaround parseIP) blue-        highlight textArea grid2D (step grid2D parseIP)yOffset-        return ()-      Just (Pop str) -> do-        colorMoves textArea grid2D (length str+4)-          (turnaround parseIP) blue-        highlight textArea grid2D (step grid2D parseIP)yOffset-        return ()-      Just (Call str) -> do-        colorMoves textArea grid2D (length str+2)-          (turnaround parseIP) blue-        highlight textArea grid2D (step grid2D parseIP)yOffset-        return ()-      Just Add1             -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Divide           -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Multiply         -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Subtract         -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Remainder        -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Cut              -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Append           -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Size             -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Nil              -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Cons             -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Breakup          -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Greater          -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Equal            -> changeColorOfEntryByCoord textArea (xC,yC) blue-      Just Start            -> changeColorOfEntryByCoord textArea (xC,yC) gold-      Just Finish           -> changeColorOfEntryByCoord textArea (xC,yC) gold-      Just (Junction _) -> do-        changeColorOfEntryByCoord textArea (xC,yC) gold-        (falseIP,trueIP) <- return $ junctionturns grid2D parseIP-        print "junction"-        print(show falseIP)-        print(show trueIP)-        highlight textArea grid2D falseIP yOffset-        highlight textArea grid2D trueIP yOffset-        return ()-      Nothing               -> changeColorOfEntryByCoord textArea (xC,yC) black-    case lex of-      Just (Junction 0) -> return crash-      Just (Push _) -> return crash-      Just (Pop _) -> return crash-      Just (Call _) -> return crash-      Just (Constant _) -> return crash -      _ -> do-        let nexIP = step grid2D parseIP-        highlight textArea grid2D nexIP yOffset-    where-      xC = posx ip-      yC = posy ip+yOffset-      blue = Color 2478 13810 63262-      green = Color 3372 62381 5732-      gold = Color 65535 30430 0-      black = Color 0 0 0-      {- moves the grid and colors the entrys used to handel Push Pop-        and Call-      -}-      colorMoves :: TextArea -> Grid2D -> Int -> IP -> Color -> IO IP-      colorMoves _ _ 0  _ _ = return crash-      colorMoves area grid2D stepsBack ip color = do-        changeColorOfEntryByCoord area (posx ip,posy ip+yOffset) color-        colorMoves area grid2D (stepsBack-1) (move ip Forward) color-        return crash-        +extendDrawingAreaHorizontally :: TextArea -> TAC.Coord -> IO ()+extendDrawingAreaHorizontally textArea x = do +  let +    drawArea = drawingArea textArea+    adjustment = hAdjustment textArea+  width <- GTK.adjustmentGetPageSize adjustment+  (w,h) <- GTK.widgetGetSizeRequest drawArea+  value <- GTK.adjustmentGetValue adjustment+  when ((x*bef)+bef >= w) $+    GTK.widgetSetSizeRequest drawArea ((x*bef)+bef) h+  when (x*bef +bef >= round width + round value || x*bef-bef < round value) $+    GTK.adjustmentSetValue adjustment $ fromIntegral (x*bef)+    +{-+  This function extends the TextArea vertically and set the scroll Frame.+  It should be called after KeyHandler +-}+extendDrawingAreaVertically :: TextArea -> TAC.Coord -> IO ()+extendDrawingAreaVertically textArea y = do +  let +    drawArea = drawingArea textArea+    adjustment = vAdjustment textArea+  height <- GTK.adjustmentGetPageSize adjustment+  (w,h) <- GTK.widgetGetSizeRequest drawArea+  value <- GTK.adjustmentGetValue adjustment+  when (y*hef + hef >= h) $+    GTK.widgetSetSizeRequest drawArea w (y*hef + hef)+  when (y*hef+hef >= round height + round value) $+    GTK.adjustmentSetValue adjustment $ value + fromIntegral hef+  when (y*hef-hef < round value) $+    GTK.adjustmentSetValue adjustment $ value - fromIntegral hef  -{-Serializes the code and delets whitespaces at the end of lines.-  It also returns the y coord of $ of functions--}-serializeIt :: TextArea -  -> (Int,Int)-  -> (String,[Int])-  -> IO(String,[Int])-serializeIt textArea (w,h) (code,indexes) = do-  (x,y) <-  readIORef $ getPointerToSize textArea-  if h > y then return (code, indexes) else-    (do-      map <- readIORef $ getPointerToEntryMap textArea-      line <- serializeItHelp map (w,h) (x,y) ""-      let clearLine = (reverse.dropWhile(==' ').reverse) line-      serializeIt textArea (0, h + 1)-        (if not (Prelude.null clearLine) && head clearLine == '$' then-            (code ++ (line ++ "\n"), indexes ++ [h]) else-            (code ++ (line ++ "\n"), indexes)))+selectEntries :: TextArea -> [TAC.Position] -> IO ()+selectEntries _ [] = return ()+selectEntries textArea (x:xs) = do+  selectEntry textArea x+  selectEntries textArea xs -serializeItHelp :: Map (Int,Int) Entry-  -> (Int,Int)-  -> (Int,Int)-  -> String-  -> IO String-serializeItHelp map (w,h) (xMax,yMax) line = -  if w >= xMax then return line else-    (do-      let elem = Map.lookup (w,h) map-      if isNothing elem then-        serializeItHelp map (w+1,h) (xMax,yMax) (line++" ") else-        (do-          let entry = fromJust elem-          content <- entryGetText entry-          serializeItHelp map (w+1,h) (xMax,yMax) (line++content)))+selectEntry :: TextArea -> TAC.Position -> IO ()+selectEntry textArea (x,y) = drawSelection textArea TAC.black 0.1 (x,y) (fromIntegral bef) (fromIntegral hef)  -serializeTextAreaContent area@(TextArea layout current hMap size) = do-  hmap <- readIORef hMap-  let list = toList hmap-  let sortedList = quicksort list-  result <- listToString sortedList [] 0-  let rightOrder = unlines $ Prelude.filter (/="") $ Prelude.map (reverse . dropWhile (== ' ') . reverse) (lines $ reverse result)-  return rightOrder-    where-      quicksort :: [((Int,Int),Entry)] -> [((Int,Int),Entry)]-      quicksort [] = []-      quicksort (x:xs) = quicksort [a | a <- xs, before a x] ++ [x] ++ quicksort [a | a <- xs, not $ before a x]+deselectEntries :: TextArea -> TAC.TextAreaContent -> [TAC.Position] -> IO ()+deselectEntries _ _ [] = return ()+deselectEntries textArea tac (x:xs) = do+  deselectEntry textArea tac x+  deselectEntries textArea tac xs+    +deselectEntry :: TextArea -> TAC.TextAreaContent -> TAC.Position -> IO ()+deselectEntry textArea tac pos  = do+  drawSelection textArea TAC.white 1 pos (bef+2) hef +  maybeCell <- TAC.getCell tac pos+  let ((char,isSelected),color) = fromJust maybeCell+  cnt <- readIORef (TAC.context tac)+  renderScene textArea pos char color (Map.findWithDefault False pos (TAC.breakMap cnt)) (pos == TAC.curIPPos cnt) -      listToString :: [((Int,Int),Entry)] -> String -> Int -> IO String-      listToString list akku beforeY = -        if Prelude.null list-        then return akku-        else do-          text <- entryGetText (snd $ head list)-          let (x,y) = fst $ head list-          if y > beforeY-          then listToString (tail list) (headE text : '\n' : akku) y-          else listToString (tail list) (headE text : akku) y+drawSelection :: TextArea -> TAC.RGBColor -> Double -> TAC.Position -> TAC.Coord -> TAC.Coord -> IO () +drawSelection textArea (TAC.RGBColor r g b) alpha (x,y) width height = do+  drawWindow <- GTK.widgetGetDrawWindow $ drawingArea textArea+  GTK.renderWithDrawable drawWindow $ do+    CAIRO.setSourceRGBA r g b alpha+    CAIRO.rectangle (fromIntegral (xCoord x)) (fromIntegral (hef * y)) (fromIntegral width) (fromIntegral height)+    CAIRO.fill -      headE a | length a == 0 = ' '-              | otherwise = head a+updatePosition :: (Double,Double) -> IO TAC.Position+updatePosition (x,y) = +  return (round leftX,round topY)+  where leftX = getMultiplier x (fromIntegral bef) 0+        topY  = getMultiplier y (fromIntegral hef) 0+  +getMultiplier :: Double -> Double -> Double -> Double+getMultiplier a b count+  | a > b * (count+1) = getMultiplier a b (count+1)+  | otherwise = count -      before :: ((Int,Int),Entry) -> ((Int,Int),Entry) -> Bool-      before ((a,b),_) ((c,d),_) = b < d || (b == d && a <= c)
+ src/RailEditor/TextAreaContent.hs view
@@ -0,0 +1,451 @@+{- |+Module      :  TextAreaContent.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann, Benjamin Kodera (c)+License     :  MIT++Stability   :  experimental++This TextAreaContent-module stores two data structures that saves all entries for the editor.+The first data structur saves the text-entries, the second data structure saves the color-entries.+-}+++module TextAreaContent (+-- * Detail+--+-- | 'TextAreaContent' is a model to be used in combination with 'TextArea' as view.++-- * Types+  TextAreaContent,+  Position,+  Direction,+  Coord,+  RGBColor(RGBColor),+  TextAreaContent.Action(Remove, Insert, RemoveLine, InsertLine, Replace, Concat, DoNothing),+  ActionQueue,+  RailType(RailString, RailList, RailLambda),+  InterpreterContext(IC), dataStack, funcStack, breakMap, inputOffset, curIPPos, railFlags,+  RailFlag(Interpret,Step,Blocked,EOFWait),++-- * Constructors+  TextAreaContent.init,   -- initializes both data structures++-- * Constants+  black,+  white,+  gold,+  green,+  blue,+  red,+  defaultColor,+  defaultChar,++-- * Methods+  serialize,+  deserialize,+  putValue,+  putColor,+  putCell,+  putDirection,+  getPositionedGrid,+  getCell,+  getDirection,+  isEmptyLine,+  findLastChar, --needed for KeyHandler+  deleteCell,+  eqPos,+  deleteColors,+  TextAreaContent.size,+  redoQueue,+  undoQueue,+  context,+  buffer,+  getSelectedPositons,+  getPositons,+  getPositonsFrom,+  setClipboard,+  getClipboard+  ) where++import qualified InterfaceDT as IDT+import Data.Map as Map+import Data.IORef+import Data.Maybe+import qualified Data.List as List+import Control.Monad+import qualified Lexer+import Graphics.UI.Gtk as Gtk++data RGBColor = RGBColor Double Double Double deriving Show+data ColorMap = CoMap  (IORef (Map Position RGBColor)) (IORef (Coord,Coord))+-- chMap is a Map(y (x coord char)) where y and x are coords+data CharMap  = ChMap  (IORef (Map Coord (Map Coord (Char,Bool)))) (IORef (Coord,Coord))++-- types for undoredo+data Action = Remove [(Char,Bool)] | Insert [(Char,Bool)] | Replace [(Char,Bool)] [(Char,Bool)] | RemoveLine | InsertLine | Concat (TextAreaContent.Action, Position) (TextAreaContent.Action, Position) | DoNothing deriving Show+type ActionQueue = [(TextAreaContent.Action, Position)]++-- types for interpreter+data RailType = RailString String | RailList [RailType] | RailLambda String Lexer.IP (Map.Map String RailType) deriving (Eq)++data RailFlag = Interpret | Step | Blocked | EOFWait deriving (Eq)++instance Show RailType+ where+  show (RailString string) = string+  show (RailList list) = show list+  show (RailLambda string ip _) = string ++ show (Lexer.posx ip, Lexer.posy ip)+data InterpreterContext = +  IC {+    dataStack :: [RailType],+    funcStack :: [(String, Lexer.IP, Map.Map String RailType)],+    breakMap :: Map Position Bool,+    inputOffset :: Int,+    curIPPos :: Position,+    railFlags :: [RailFlag]+  }++data TextAreaContent = +  TAC {+    charMap :: CharMap,+    colorMap :: ColorMap,+    undoQueue :: IORef ActionQueue,+    redoQueue :: IORef ActionQueue,+    railDirection :: IORef Direction,+    context :: IORef InterpreterContext,+    buffer :: (Gtk.TextBuffer,Gtk.TextBuffer),+    clipboard :: IORef [(Position,(Char,Bool))]+  }+  +type Coord = Int+type Position = (Coord,Coord)+type Direction = (Coord,Coord)++-- Constants+red   = RGBColor 1.0                  0                   0+blue  = RGBColor 3.781185626001373e-2 0.21072709239337759 0.965316243228809+green = RGBColor 5.145342183566033e-2 0.9518730449378194  8.746471351186388e-2+gold  = RGBColor 1.0                  0.46433203631647213 0.0+black = RGBColor 0                    0                   0+white = RGBColor 1.0                  1.0                 1.0++defaultColor = red+defaultChar = ' '+++--------------------+-- Constructors++-- | creates a new TextAreaContent+init :: Coord -- ^ x-size+  -> Coord -- ^ y-size+  -> Gtk.TextBuffer+  -> Gtk.TextBuffer+  -> IO TextAreaContent+init x y inputBuffer outputBuffer= do+  size <- newIORef (x,y)+  hmapR <- newIORef Map.empty+  cmapR <- newIORef Map.empty+  undoQ <- newIORef []+  redoQ <- newIORef []+  dir <- newIORef (1,0)+  cont <- newIORef $ IC [] [] Map.empty 0 (-1, -1) []+  clipb <- newIORef []+  let +    cMap = CoMap cmapR size+    hMap = ChMap hmapR size+  return $ TAC hMap cMap undoQ redoQ dir cont (inputBuffer,outputBuffer) clipb++--------------------+-- Methods++--To compare Positions+eqPos :: Position -> Position -> Bool+eqPos (x,y) (u,v) = (x==u)&&(y==v)++--fill a Map a (Map a b) with a specified content+fillCharMapWith :: Map.Map Coord (Map.Map Coord (Char,Bool)) --Map of content at position y x+  -> (Char,Bool) --Content+  -> Position -- size+  -> Map.Map Coord (Map.Map Coord (Char,Bool))--Map with content at every y x coord (x*y operations)+fillCharMapWith charMap content (xBound,yBound) =+  Prelude.foldl (\yMap yK -> +    if isNothing $ Map.lookup yK yMap -- line Map nothing?+    then insert --insert the filled xMap into yMap+      yK +      (Prelude.foldl (\xMap xK -> --foldl with empty map+        if isNothing $ Map.lookup xK xMap --check for char at x,y+        then Map.insert xK content xMap +        else xMap) Map.empty [0..xBound])+      yMap+    else insert --insert the filled xMap into yMap+      yK+      (Prelude.foldl (\xMap xK -> --foldl with+        if isNothing $ Map.lookup xK xMap --check for char at x,y+        then Map.insert xK content xMap +        else xMap)(fromJust $ Map.lookup yK yMap)[0..xBound])+       yMap+  )charMap [0..yBound]++--fills a map with a specified content+fillMapWith :: Map.Map Position a -> a -> Coord -> Coord -> Coord -> Coord -> Map.Map Position a+fillMapWith map content _ _ 0 0 = Map.insert (0,0) content map+fillMapWith map content xBound yBound 0 y = fillMapWith (Map.insert (0,y) content map) content xBound yBound xBound (pred y)+fillMapWith map content xBound yBound x y = fillMapWith (Map.insert (x,y) content map) content xBound yBound (pred x) y++-- | creates a string by a TextAreaContent+serialize :: TextAreaContent+  -> IO String+serialize areaContent = do+  let (ChMap hMap size) = charMap areaContent --get the CharMap pointer+  hmap <- readIORef hMap --get the CharMap+  (xMax,yMax) <- readIORef size --get the size of the CharMap+  --Fill the map with whitespaces+  let +    wMap = fillCharMapWith hmap (' ',False) (xMax,yMax)+    listOfLines = assocs wMap+  foldM (\code (y,lineMap) -> do+      let lineList = assocs lineMap+      l <- foldM (\line (x,(char,_)) -> return $ line++[char]) "" lineList+      let cleanLine = (reverse . dropWhile (== ' ') . reverse) l ++ "\n"+      return $ code++cleanLine+    ) "" listOfLines+   +-- | creates a TextAreaContent by a string+deserialize :: String+  -> Gtk.TextBuffer+  -> Gtk.TextBuffer+  -> IO TextAreaContent+deserialize stringContent inputB outputB = do+  areaContent <- TextAreaContent.init newX newY inputB outputB+  --readStringListInEntryMap areaContent lined (0,0) +  foldM_ (\y line -> do+    foldM_ (\x char -> do +        putValue areaContent (x,y) (char,False)+        return $ x+1+      ) 0 line +    return $ y+1+    ) 0 lined +  return areaContent+  where+    newX = maximum $ Prelude.map length lined+    newY = length lined+    lined = lines stringContent++--set the size(x,y) to (x+1,y+1)+resize :: TextAreaContent -> Position-> IO ()+resize areaContent (xm,ym) = do+  let +    (ChMap charMapIORef charSize) = charMap areaContent+    (CoMap colorMapIORef colorSize) = colorMap areaContent+  writeIORef charSize (xm,ym)+  writeIORef colorSize (xm,ym)++-- | sets the character for a cell identified by a coordinate+-- If the coords are out of bounds the function resizes the TAC.+putValue :: TextAreaContent+  -> Position -- ^ coordinates of the required cell+  -> (Char,Bool) -- ^ character and selection state+  -> IO ()+putValue areaContent (x,y) content = do+  (xMax,yMax) <- TextAreaContent.size areaContent+  if y > yMax || x > xMax+  then do +    resize areaContent (xMax + abs (xMax-x),yMax + abs (yMax-y))+    putValue areaContent (x,y) content+  else do+    let +      (ChMap hMap size) = charMap areaContent+      (CoMap cMap _) = colorMap areaContent+    valHMap <- readIORef hMap+    let lineMap = Map.lookup y valHMap+    modifyIORef' hMap $ Map.insert y $ maybe (insert x content empty) (insert x content) lineMap++-- | sets the color of a cell identified by +-- If the coords are out of bounds the function resizes the TAC.+putColor :: TextAreaContent+  -> Position -- ^ coordinates of the required cell+  -> RGBColor -- ^ color to put+  -> IO ()+putColor areaContent (x,y) color = do+  (xMax,yMax) <- TextAreaContent.size areaContent+  if x > xMax || y > yMax+  then do+    resize areaContent (xMax + abs (xMax-x),yMax + abs (yMax-y))+    putColor areaContent (x,y) color+  else do+    let (CoMap cMap _) = colorMap areaContent+    modifyIORef' cMap $ Map.insert (x,y) color++deleteColors :: TextAreaContent -> IO ()+deleteColors tac = do+  let(CoMap cMap _) = colorMap tac+  writeIORef cMap Map.empty++-- / sets a cell+putCell :: TextAreaContent+  -> Position -- ^ coordinates of the required cell+  -> ((Char,Bool),RGBColor) -- ^ content and color to put+  -> IO ()+putCell areaContent coord (content,color) = do+  putColor areaContent coord color+  putValue areaContent coord content++-- | setting input direction+putDirection :: TextAreaContent+  -> Direction+  -> IO ()+putDirection tac dir = do+  let dirTac = railDirection tac+  modifyIORef dirTac $ const dir++-- | getting input direction+getDirection :: TextAreaContent+  -> IO Direction+getDirection tac = do+  let dirTac = railDirection tac+  readIORef dirTac++-- | delets a cell+deleteCell :: TextAreaContent +  -> Position+  -> IO Bool+deleteCell areaContent (x,y) = do+  let +    (ChMap hMap _) = charMap  areaContent+    (CoMap cMap _) = colorMap areaContent+  (xMax,yMax) <- TextAreaContent.size areaContent+  if x > xMax || y > yMax+  then return False+  else do+    modifyIORef hMap (\m -> del m (x,y))+    modifyIORef cMap (Map.delete (x,y))+    return True+  where+    delMap :: Map.Map Coord (Map.Map Coord (Char,Bool)) -> Position -> Map.Map Coord (Char,Bool)+    delMap m (x,y) = maybe Map.empty (Map.delete x) (Map.lookup y m)+    del :: Map.Map Coord (Map.Map Coord (Char,Bool)) -> Position -> Map.Map Coord (Map.Map Coord (Char,Bool))+    del m (x,y)+      | delMap m (x,y) == Map.empty = Map.delete y m+      | otherwise = Map.insert y (delMap m (x,y)) m+     +-- | returns the character and the color of a cell+getCell :: TextAreaContent +  -> Position -- ^ coordinates of the required cell+  -> IO (Maybe ((Char,Bool),RGBColor))+getCell areaContent (x,y) = do+  let (ChMap hMap _) = charMap areaContent+  let (CoMap cMap _) = colorMap areaContent+  hmap <- readIORef hMap+  cmap <- readIORef cMap+  let valMap =  Map.lookup y hmap+  let color =  Map.findWithDefault defaultColor (x,y) cmap --now lazy+  return $ if isNothing valMap then Nothing else do+      let mayValue = Map.lookup x $ fromJust valMap+      if isNothing mayValue then Nothing else Just (fromJust mayValue, color)+       +-- / checks if line is empty+isEmptyLine :: TextAreaContent+  -> Coord+  -> IO Bool+isEmptyLine areaContent line = do+  let (ChMap hMap _) = charMap areaContent+  hmap <- readIORef hMap+  return $ isNothing $ Map.lookup line hmap++{-This function is important for highlighting it returns the datatype+  which Lexer needs to lex. -}+getPositionedGrid :: TextAreaContent -> IO IDT.PreProc2Lexer+getPositionedGrid areaContent = do+  let (ChMap hMap hSize) = charMap areaContent+  s@(xMax,yMax) <- readIORef hSize+  hmap <- readIORef hMap+  pGrid <- buildPosGrid ([],0) (assocs hmap)+  return $ IDT.IPL (Prelude.map (maximize (max xMax yMax)) $ fst pGrid)+  where+    maximize :: Int -> IDT.PositionedGrid -> IDT.PositionedGrid+    maximize msize (grid, offset) = (Map.update updatefirst 0 grid, offset)+      where+        updatefirst line = Just $ Map.union line emptymap+        emptymap = fromList $ zip [0..msize] (repeat ' ')+    buildPosGrid :: ([IDT.PositionedGrid],Int) -> [(Int,Map.Map Int (Char,Bool))] -> IO ([IDT.PositionedGrid],Int)+    buildPosGrid = foldM  +      (\(grids,offset) (y,line) -> do+        let mayDollar = Map.lookup 0 line +            simplifiedLine = Map.map fst line+        return $ +          if isNothing mayDollar+          then (insertWhenFct grids simplifiedLine y offset,offset)+          else+            if fst (fromJust mayDollar) == '$'+            then (grids ++ [(Map.insert 0 simplifiedLine Map.empty, y)], y)+            else (insertWhenFct grids simplifiedLine y offset, offset)+      )+    +    insertWhenFct :: [IDT.PositionedGrid] -> Map.Map Int Char -> Int -> Int -> [IDT.PositionedGrid]+    insertWhenFct x line y  offset +      | List.null x || line == Map.empty = x+      | otherwise = List.init x ++[(Map.insert (y-offset) line (fst (last x)), snd (last x))]+ +findLastChar :: TextAreaContent -> Coord -> IO Coord+findLastChar tac y = do+  let (ChMap hMap _) = charMap tac+  hmap <- readIORef hMap+  let mayLine = Map.lookup y hmap+  return $ if isNothing mayLine then -1 else fst $ List.last $ assocs $ fromJust mayLine+  +-- | returns the size of a TextAreaContent.+size :: TextAreaContent+  -> IO Position -- ^ size of the TextAreaContent+size areaContent = do +  let (ChMap _ size) = charMap areaContent+  readIORef size++getSelectedPositons :: TextAreaContent -> IO [Position]+getSelectedPositons areaContent = do+  (xMax,yMax) <- TextAreaContent.size areaContent+  filterM (isSelected areaContent) [ (x,y) | y <- [0..yMax], x <- [0..xMax]]+  +isSelected :: TextAreaContent -> Position -> IO Bool+isSelected tac pos = do+  cell <- getCell tac pos+  return $ isJust cell && snd (fst $ fromJust cell)+  +getPositons :: TextAreaContent -> IO [Position]+getPositons areaContent = do+  (xMax,yMax) <- TextAreaContent.size areaContent+  filterM (isOccupied areaContent) [ (x,y) | y <- [0..yMax], x <- [0..xMax]]++getPositonsFrom :: TextAreaContent -> Position -> IO [Position]+getPositonsFrom areaContent (_,y) = do+  (xMax,yMax) <- TextAreaContent.size areaContent+  filterM (isOccupied areaContent) [ (x1,y1) | y1 <- [0..yMax], x1 <- [0..xMax], y1 > y]++-- Is a char at pos ?+isOccupied :: TextAreaContent -> Position -> IO Bool+isOccupied tac pos = do+  cell <- getCell tac pos+  return $ isJust cell++setClipboard :: TextAreaContent -> IO ()+setClipboard tac = do+  positions <- getSelectedPositons tac+  cells <- getCellsByPositions tac positions+  writeIORef (clipboard tac) (List.zip positions cells)++getClipboard :: TextAreaContent -> IO [(Position,(Char,Bool))]+getClipboard tac = readIORef (clipboard tac)++getCellsByPositions :: TextAreaContent -> [Position] -> IO [(Char,Bool)]+getCellsByPositions _ [] = return []+getCellsByPositions tac positions = _getCellsByPositions tac positions []++_getCellsByPositions :: TextAreaContent -> [Position] -> [(Char,Bool)] -> IO [(Char,Bool)]+_getCellsByPositions _ [] cells = return cells+_getCellsByPositions tac (x:xs) cells = do+  cell <- getCell tac x+  _getCellsByPositions tac xs $+    if isJust cell +    then cells ++ [fst $ fromJust cell]+    else cells
+ src/RailEditor/TextAreaContentUtils.hs view
@@ -0,0 +1,185 @@+{- |+Module      :  TextAreaContentUtils.hs+Description :  .+Maintainer  :  Kristin Knorr (c)+License     :  MIT++Stability   :  stable++'TextAreaContentUtils' serves methods to move Characters in TextAreaContent.++-}++module TextAreaContentUtils (+-- * Methods+  moveChars,+  findLastCharBefore,+  moveLinesUp,+  moveLinesDownXShift,+  moveCharsRight,+  mvLinesUp+  ) where++import Graphics.UI.Gtk+import Data.IORef+import Data.Maybe+import Data.Map as Map+import Control.Monad++import qualified TextAreaContent as TAC+++-- | calculates Destination depending on Direction+calculateDest :: TAC.Position+  -> TAC.Direction+  -> TAC.Position+calculateDest (stX,stY) (dirX,dirY) = (stX+dirX,stY+dirY)++-- | moves Contents into a Direction+moveChar :: TAC.TextAreaContent+  -> TAC.Position+  -> TAC.Direction+  -> IO()+moveChar area from dir = do+  x <- TAC.getCell area from+  unless (isNothing x) $ do+    let+      cell = fromJust x+      to = calculateDest from dir+    TAC.putCell area to cell+    TAC.deleteCell area from+    return ()++-- | moves amount of Characters of one line in range from Pos x to last char in line+moveChars :: TAC.TextAreaContent+  -> TAC.Position+  -> TAC.Direction+  -> IO()+moveChars area (stX, line) dir = do+  endX <- TAC.findLastChar area line+  unless (stX > endX) $+    if snd dir == 0 && fst dir > 0+    then+      moveCharsRight area stX endX line dir+    else do+      moveChar area (stX,line) dir+      moveChars area (stX+1,line) dir+      return ()+  where+    moveCharsRight area stX endX line dir = +      unless (stX > endX) $ do+        moveChar area (endX,line) dir+        moveCharsRight area stX (endX-1) line dir+        return ()++{- |+ searchs for last character in Line and returns x-Position, if Line is empty+ return -1+-}++findLastCharBefore :: TAC.TextAreaContent+  -> TAC.Coord+  -> TAC.Coord+  -> IO TAC.Coord+findLastCharBefore area x line =+  if x<0+  then return (-1)+  else do+    cont <- TAC.getCell area (x,line)+    if isJust cont+    then return x+    else findLastCharBefore area (x-1) line++-- | searchs for last written Line+findLastWrittenLine :: TAC.TextAreaContent+  -> IO TAC.Coord+findLastWrittenLine area = do+  size <- TAC.size area+  findLastWrittenLineHelper area (snd size)+  where+    findLastWrittenLineHelper area line =+      if line<0+      then return(-1)+      else do+        empty <- TAC.isEmptyLine area line+        if empty+        then findLastWrittenLineHelper area (line-1)+        else return line++-- | moves Lines up where param line is the upper line+moveLinesUp :: TAC.TextAreaContent+  -> TAC.Coord+  -> IO()+moveLinesUp area line = do+  finY <- findLastWrittenLine area+  moveLinesUpHelper area line line finY+  where+      moveLinesUpHelper area line stY finY = +        unless (line<=0 || line>finY) $ do+          empty <- TAC.isEmptyLine area line+          if empty+          then moveLinesUpHelper area (line+1) stY finY+          else+            if line == stY+            then do+              lastPrev <- TAC.findLastChar area (line-1)+              moveChars area (0,line) (lastPrev+1, -1)+              moveLinesUpHelper area (line+1) stY finY+            else do+              moveChars area (0,line) (0,-1)+              moveLinesUpHelper area (line+1) stY finY++{- |+ moves Lines down where param line upper Line+ param xShift is a Boolean, which defines wether+ the upper line starting at posx is shifted vertically down (False)+ or is shifted down to pos 0 (True)+-}+moveLinesDownXShift :: TAC.TextAreaContent+  -> TAC.Position+  -> Bool+  -> IO()+moveLinesDownXShift area (posX,line) xShift = do+  lastLine <- findLastWrittenLine area+  unless (line>lastLine || line<0) $+    if line==lastLine+    then +      moveChars area (posX,line) $+        if xShift then (-posX,1) else (0,1)+    else+      if xShift+      then do+        moveLinesVertDown area (line+1)+        moveChars area (posX,line) (-posX,1)+      else do+        moveLinesVertDown area (line+1)+        moveChars area (posX,line) (0,1)++-- | moves all chars of lines lower "line" to one line lower+moveLinesVertDown :: TAC.TextAreaContent+  -> TAC.Coord+  -> IO()+moveLinesVertDown area line = do+  lastLine <- findLastWrittenLine area+  moveDownHelper area lastLine line+  where+    moveDownHelper area line stY =+      unless (line<stY) $ do+        empty <- TAC.isEmptyLine area line+        if empty+        then moveDownHelper area (line-1) stY+        else do+          moveChars area (0,line) (0,1)+          moveDownHelper area (line-1) stY++moveCharsRight :: TAC.TextAreaContent -> TAC.Position -> TAC.Position -> TAC.Position -> IO TAC.Position+moveCharsRight tac (x,y) topLeft@(xLeft,yTop) bottomRight@(xRight,yBottom) = do+  moveChars tac bottomRight $ if (x,y) == topLeft then (x - xRight - 1, y - yBottom) else (xLeft - x, yTop - y)+  return topLeft++mvLinesUp :: TAC.TextAreaContent -> TAC.Coord -> Int -> (TAC.Action, TAC.Position) -> IO (TAC.Action, TAC.Position)+mvLinesUp _ _ 0 action = return action+mvLinesUp tac y diff action = do +  moveLinesUp tac y+  mvLinesUp tac (y-1) (diff-1) (TAC.Concat action (TAC.RemoveLine, (0,y-1)), (0, y))+
+ src/RailEditor/ToolBar.hs view
@@ -0,0 +1,138 @@+{- |+Module      :  ToolBar.hs+Description :  .+Maintainer  :  Kelvin Glaß, Chritoph Graebnitz, Kristin Knorr, Nicolas Lehmann (c)+License     :  MIT++Stability   :  experimental++The ToolBar-module depicts the tool bar at the top of the main window below the menu bar.+-}+module ToolBar (+  create+               )+  where++    -- imports --++import Data.IORef+import qualified KeyHandler as KH+import qualified FooterBar as FB+import qualified InteractionField as IDF+import qualified TextArea as TA+import qualified Graphics.UI.Gtk as Gtk+import qualified Interpreter as IN+import qualified Lexer+import qualified TextAreaContent as TAC+import qualified Data.Map as Map+import Control.Monad+    -- functions --++processWith area dataBuffer funcBuffer fn = do+      tac <- readIORef $ TA.textAreaContent area+      intCtxt <- readIORef $ TAC.context tac+      fn tac+      intCtxt <- readIORef $ TAC.context tac+      TA.redrawContent area+      Gtk.textBufferSetText dataBuffer $ unlines $ map show $ TAC.dataStack intCtxt+      Gtk.textBufferSetText funcBuffer $ unlines $ map (\(x,_,_)->x) $ TAC.funcStack intCtxt+      let fS = TAC.funcStack intCtxt+      if not (null fS)+      then do+        let ip = (\(_,x,_) -> (Lexer.posx x,Lexer.posy x)) $ head fS+        print ip+      else do+        let ip = (0,0)+        print ip+      return True++-- | creates a toolbar+create area footer interDT= do++    toolBar <- Gtk.menuBarNew++    -- create step button+    image <- Gtk.imageNewFromStock Gtk.stockMediaPlay Gtk.IconSizeMenu+    step <- Gtk.imageMenuItemNewWithLabel ""+    Gtk.imageMenuItemSetImage step image+    Gtk.menuShellAppend toolBar step++    -- create run button+    imageD <- Gtk.imageNewFromStock Gtk.stockGoForward Gtk.IconSizeMenu+    run <- Gtk.imageMenuItemNewWithLabel ""+    Gtk.imageMenuItemSetImage run imageD+    Gtk.menuShellAppend toolBar run++    variables <- Gtk.menuItemNewWithLabel "variables"++    reset <- Gtk.menuItemNewWithLabel "reset"++    -- create mode-menu+    mode <- Gtk.menuNew++    -- create modes+    insertMode <- Gtk.radioMenuItemNewWithLabel "insert"+    replaceMode <- Gtk.radioMenuItemNewWithLabelFromWidget insertMode "replace"+    smartMode <- Gtk.radioMenuItemNewWithLabelFromWidget insertMode "smart"++    highlightCheck <- Gtk.checkMenuItemNewWithLabel "highlighting"+    Gtk.checkMenuItemSetActive highlightCheck True+    let dataBuffer = IDF.getDataStackBuffer interDT+    let funcBuffer = IDF.getFunctionStackBuffer interDT++    Gtk.onButtonPress run  $ \event -> processWith area dataBuffer funcBuffer IN.interpret++    Gtk.onButtonPress step $ \event -> processWith area dataBuffer funcBuffer IN.step++    bufferVariables <- Gtk.textBufferNew Nothing++    Gtk.onButtonPress variables $ \event -> do+      tac <- readIORef $ TA.textAreaContent area+      intCtxt <- readIORef $ TAC.context tac+      let list = TAC.funcStack intCtxt+      unless (null list) $ do+        let vars = unlines $ map (\(x,y)-> x ++ " = " ++ show y) $ Map.toList $ (\(_,_,x) -> x)$ head list+        Gtk.textBufferSetText bufferVariables vars+        Gtk.postGUIAsync $ IDF.textViewWindowShow bufferVariables "Variables"+      return True++    Gtk.onButtonPress reset $ \event-> do+      tac <- readIORef $ TA.textAreaContent area+      Gtk.textBufferSetText bufferVariables ""+      Gtk.textBufferSetText dataBuffer ""+      Gtk.textBufferSetText funcBuffer ""+      IN.reset tac+      TA.redrawContent area+      return True++    -- set mode action+    Gtk.on insertMode Gtk.menuItemActivate$ do+      TA.setInputMode area KH.Insert+      FB.setMode footer KH.Insert++    Gtk.on replaceMode Gtk.menuItemActivate $ do+      TA.setInputMode area KH.Replace+      FB.setMode footer KH.Replace++    Gtk.on smartMode Gtk.menuItemActivate$ do+      TA.setInputMode area KH.Smart+      FB.setMode footer KH.Smart++    Gtk.on highlightCheck Gtk.menuItemActivate$ do+      isActive <- Gtk.checkMenuItemGetActive highlightCheck+      TA.setHighlighting area isActive++    -- configure mode-menu+    modeItem <- Gtk.menuItemNewWithLabel "mode"+    Gtk.menuItemSetSubmenu modeItem mode++    Gtk.menuShellAppend toolBar modeItem++    Gtk.menuShellAppend mode insertMode+    Gtk.menuShellAppend mode replaceMode+    Gtk.menuShellAppend mode smartMode+    Gtk.menuShellAppend mode highlightCheck+    Gtk.menuShellAppend toolBar variables+    Gtk.menuShellAppend toolBar reset++    return toolBar
tests/Main.hs view
@@ -8,7 +8,6 @@ import qualified TSynAna import qualified TSemAna import qualified TInterCode-import qualified TCodeOpt import qualified TBackend  import System.Exit@@ -27,7 +26,6 @@     TSynAna.testModule ++     TSemAna.testModule ++     TInterCode.testModule ++-    TCodeOpt.testModule ++     TBackend.testModule     )   testexit <- system "tests/integration_tests"
− tests/TCodeOpt.hs 
@@ -1,19 +0,0 @@-module TCodeOpt (-                    testModule     -- tests the module CodeOptimization-                   )- where-- -- imports --- import Test.HUnit- import InterfaceDT                   as IDT- import qualified CodeOptimization    as CodeOpt-- -- functions --- -- testCodeOpt01 = "CodeOptimization: " ~: (erwarteter wert) @=? (CodeOpt.process eingabe)- -- testCodeOpt02 = "CodeOptimization: " ~: (erwarteter wert) @=? (CodeOpt.process eingabe)- -- testCodeOpt03 = "CodeOptimization: " ~: (erwarteter wert) @=? (CodeOpt.process eingabe)- -- testCodeOpt04 = "CodeOptimization: " ~: (erwarteter wert) @=? (CodeOpt.process eingabe)- -- testCodeOpt05 = "CodeOptimization: " ~: (erwarteter wert) @=? (CodeOpt.process eingabe)- -- ...- - testModule = [] -- [testCodeOpt01,testCodeOpt02,testCodeOpt03,testCodeOpt04,testCodeOpt05]
tests/TLexer.hs view
@@ -6,6 +6,7 @@  -- imports --  import Test.HUnit  import InterfaceDT                   as IDT+ import qualified Preprocessor        as PreProc  import qualified Lexer   -- functions --@@ -13,7 +14,7 @@  testLexer02 = "Reflection: " ~: res [Constant "1"] @=? run [" \\", "  \\   #  #  #", "   \\   f f f", "    \\   \\|/", " #t-------@-f#", "         /|\\", "        f f f", "       #  #  #"]  testLexer03 = "Rail crash: " ~: crash @=? run [" /", "#"]  testLexer04 = "One liner: " ~: crash @=? run []- testLexer05 = "Endless loop: " ~: IDT.ILS [("main",[(1,Start,2),(2,Constant "1",3),(3,NOP,3)])] @=? run [" 1 ", "  \\", " @--@"]+ testLexer05 = "Endless loop: " ~: IDT.ILS [("main",[(1,Start,2),(2,Constant "1",3),(3,NOP,3)])] @=? run [" \\", "  1 ", "   \\", "  @--@"]  testLexer06 = "Junction test: " ~: IDT.ILS [("main", [(1, Start, 2), (2, Junction 3, 5), (3, Constant "1", 4), (4, Finish, 0), (5, Constant "0", 6), (6, Finish, 0)])] @=? run [" \\", "  \\  /-1#", "   -<", "     \\-0#"]  testLexer07 = "Simple Junction test: " ~: crash @=? run [" *-1#"]  testLexer08 = "Two Junctions: " ~: IDT.ILS [("main", [(1, Start, 2), (2, Junction 3, 5), (3, Junction 4, 5), (4, Finish, 0), (5, Constant "0", 6), (6, Finish, 0)])] @=? run [" \\    --\\     -#", "  \\  /   \\   /", "   -<     --<", "     \\       \\", "      ---------0#"]@@ -23,10 +24,14 @@  testLexer12 = "While: " ~: IDT.ILS [("main", [(1, Start, 2), (2, EOF, 3), (3, Junction 2, 4), (4, Finish, 0)])] @=? run [" \\   /----\\", "  \\  |    |", "   \\ \\    /", "    ---e-<", "          \\-#"]  testLexer13 = "Empty Junction ends: " ~: IDT.ILS [("main",[(1, Start, 2), (2, Junction 0, 3), (3, Junction 4, 0), (4, Junction 5, 6), (5, Finish, 0), (6, Finish, 0)])] @=? run [" \\", "  \\    /      /--\\   /-#", "   \\--<    --<    --<", "       \\--/   \\      \\-#"]  testLexer14 = "Turning on Lexeme: " ~: crash @=? run [" \\", "  \\#"]+ testLexer15 = "Lambda: " ~: IDT.ILS [("main",[(1, Start, 2), (2, Lambda 3, 5), (3, Underflow, 4), (4, Finish, 0), (5, Finish, 0)])] @=? run [" \\", "#--&u#"]+ testLexer16 = "Empty Lambda: " ~: IDT.ILS [("main",[(1, Start, 2), (2, Lambda 0, 3), (3, Finish, 0)])] @=? run [" \\", "#--&"]+ testLexer17 = "\\\\ Escaping: " ~: res [Constant "\\"] @=? run [" \\-[\\\\]#"]+ testLexer18 = "Dot Command: " ~: crash @=? run [" .", "  #"]   -- helper functions- run :: IDT.Grid2D -> IDT.Lexer2SynAna- run grid = Lexer.process (IDT.IPL ["$ 'main'":grid])+ run :: [String] -> IDT.Lexer2SynAna+ run grid = Lexer.process (PreProc.process (IIP (unlines ("$ 'main'":grid))))   res :: [Lexeme] -> IDT.Lexer2SynAna  res lexeme = IDT.ILS [("main", (1, Start, 2):nodes 2 lexeme)]@@ -37,4 +42,4 @@  crash :: IDT.Lexer2SynAna  crash = IDT.ILS [("main", [(1, Start, 0)])]  - testModule = [testLexer01, testLexer02, testLexer03, testLexer04, testLexer05, testLexer06, testLexer07, testLexer08, testLexer09, testLexer10, testLexer11, testLexer12, testLexer13, testLexer14]+ testModule = [testLexer01, testLexer02, testLexer03, testLexer04, testLexer05, testLexer06, testLexer07, testLexer08, testLexer09, testLexer10, testLexer11, testLexer12, testLexer13, testLexer14, testLexer15, testLexer16, testLexer17, testLexer18]
tests/TPreProc.hs view
@@ -7,13 +7,17 @@  import Test.HUnit  import InterfaceDT                   as IDT  import qualified Preprocessor        as PreProc+ import qualified Data.Map            as Map    -- functions --  --testPreProc01   = "PreProc: " ~: IDT.IPL [] @=? PreProc.process (IDT.IIP "")  --testPreProc02   = "PreProc: " ~: IDT.IPL [] @=? PreProc.process (IDT.IIP "a\nb\n")- testPreProc03   = "PreProc: " ~: IDT.IPL [["$1"], ["$2"]] @=? PreProc.process (IDT.IIP "$1\n$2\n")- testPreProc04   = "PreProc: " ~: IDT.IPL [["$1"], ["$2", "", "", ""], ["$3", "", "", "", ""]] @=? PreProc.process (IDT.IIP "$1\n$2\n\n\n\n$3\n\n\n\n\n")+ testPreProc03   = "PreProc: " ~: IDT.IPL [(convert ["$1"], 0), (convert ["$2"], 1)] @=? PreProc.process (IDT.IIP "$1\n$2\n")+ testPreProc04   = "PreProc: " ~: IDT.IPL [(convert ["$1"], 0), (convert ["$2  ", "", "", ""], 1), (convert ["$3   ", "", "", "", ""], 5)] @=? PreProc.process (IDT.IIP "$1\n$2\n\n\n\n$3\n\n\n\n\n")  --testPreProc05   = "PreProc: " ~: IDT.IPL [["$2"]] @=? PreProc.process (IDT.IIP " $1\n$2\n")+ + convert :: [String] -> Grid2D+ convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code)     testModule = [testPreProc03,testPreProc04]
tests/TSynAna.hs view
@@ -9,10 +9,10 @@  import qualified SyntacticalAnalysis as SynAna   -- functions --- testSynAna01 = "SyntactiaclAnalysis: " ~: output1 @=? SynAna.process input1- testSynAna02 = "SyntactiaclAnalysis: " ~: output2 @=? SynAna.process input2- testSynAna03 = "SyntactiaclAnalysis: " ~: output3 @=? SynAna.process input3- testSynAna04 = "SyntactiaclAnalysis: " ~: output4 @=? SynAna.process input4+ testSynAna01 = "SyntactiaclAnalysis 1: " ~: output1 @=? SynAna.process input1+ testSynAna02 = "SyntactiaclAnalysis 2: " ~: output2 @=? SynAna.process input2+ testSynAna03 = "SyntactiaclAnalysis 3: " ~: output3 @=? SynAna.process input3+ testSynAna04 = "SyntactiaclAnalysis 4: " ~: output4 @=? SynAna.process input4    input1  = ILS [("main", [(1,Start,2),(2, Constant "Hello World!", 3),(3, Output, 4),(4, Finish, 0)])]  output1 = ISS [("main", [(1,[Start, Constant "Hello World!", Output, Finish],0)])]
tests/integration_tests view
@@ -3,9 +3,10 @@ ### Usage info function show_help { cat << EOF-Usage: ${0##*/} [-hvl] [-e/d TEST] [TEST]...+Usage: ${0##*/} [-hvl] [-e/d TEST] [TEST/TESTDIR] Without arguments the script runs all enabled tests. When a test name is given then run this test.+When a directory is given it runs all tests in that directory.  -h         Display this help and exit -e/d TEST  Enable/Diasble the specified test.@@ -13,6 +14,14 @@ -r         Run all not enabled tests. -v         Verbose mode. Can be used multiple times for increased            verbotisty.+-c         Use C++ compiler/runtime system.+-i         Use the rail interpreter.+-a         Generate an AST file with the c++ rail compiler and read+           it into the haskell compiler. When using -ca the haskell+           compiler generates the AST and the cpp-compiler reads that AST.+-o FILE    Write expected outputs and actual outputs to FILE.exp, +           FILE.exp.err, FILE and FILE.err.+           Don't do the actual output comparision here. EOF } @@ -85,7 +94,7 @@ function run_one {   dontrun=false   filename=$(get_name "$1")-+  unset compilefail   if [ -f "$TESTDIR/$filename$EXT" ]     then       readtest "$TESTDIR/$filename$EXT"@@ -94,37 +103,46 @@       echo -e "`$red`ERROR`$NC` testing: \"$filename.rail\". $EXT-file is missing."       return   fi--  errormsg=$(dist/build/RailCompiler/RailCompiler -c -i "$1" -o "$TMPDIR/$filename.ll" 2>&1) \-    && llvm-link "$TMPDIR/$filename.ll" src/RailCompiler/stack.ll > "$TMPDIR/$filename" \-    && chmod +x "$TMPDIR/$filename" || {-      TOTAL_TESTCASES=$(($TOTAL_TESTCASES + 1))--      # Check STDOUT first for backward compatibility.-      if [[ "$errormsg" == "${STDOUT[0]}" || "$errormsg" == "${STDERR[0]}" ]]; then-        [ $verbose -gt 0 ] && echo -en "`$green`Passed`$NC` expected fail \"$filename.rail\"."-	if [ $verbose -gt 1 ]; then-          echo "  The error message was: \"$errormsg\""-        else-          [ $verbose -gt 0 ] && echo -ne "\n"-        fi+  if [[ -n "$ast" ]]; then +    return+  fi+  if [[ -z $cpp && -z $interpreter ]]; then+    # Run Haskell compiler and llvm-linker.+    errormsg=$(dist/build/RailCompiler/RailCompiler -c -i "$1" -o "$TMPDIR/$filename.ll" 2>&1) \+      && errormsg2=$(llvm-link "$TMPDIR/$filename.ll" src/RailCompiler/*.ll 2>&1 > "$TMPDIR/$filename") \+      && chmod +x "$TMPDIR/$filename" || compilefail=true+  elif [ -n "$cpp" ]; then+    # Run C++ compiler.+    errormsg=$($CPPCOMPILER -q -i "$1" -o "$TMPDIR/$filename.class" 2>&1) || compilefail=true+  fi+  if [ -n "$compilefail" ]; then+    TOTAL_TESTCASES=$(($TOTAL_TESTCASES + 1))+    if [ -n "$fileoutput" ]; then+      echo "$filename" >> "${fileoutput}.tests"+      echo "$errormsg" >> "${fileoutput}.err"+      echo "${STDERR[0]}" >> "${fileoutput}.exp.err"+    elif [[ "$errormsg$errormsg2" == "${STDERR[0]}" ]]; then+      [ $verbose -gt 0 ] && echo -en "`$green`Passed`$NC` expected fail \"$filename.rail\"."+      if [ $verbose -gt 1 ]; then+        echo "  The error message was: \"$errormsg$errormsg2\""       else-        fail=$(($fail + 1))-        echo -e "`$red`ERROR`$NC` compiling/linking \"$filename.rail\" with error: \"$errormsg\""+        [ $verbose -gt 0 ] && echo -ne "\n"       fi--      return-  }-+    else+      fail=$(($fail + 1))+      echo -e "`$red`ERROR`$NC` compiling/linking \"$filename.rail\" with error: \"$errormsg$errormsg2\""+    fi+    return+  fi   # Create temporary files for stdout and stderr.-  stdoutfile=$(mktemp --tmpdir="$TMPDIR" swp14_ci_stdout.XXXXX)+  stdoutfile=$(mktemp -t swp14_ci_stdout.XXXXX)   if [ $? -gt 0 ]; then     echo -e "`$red`ERROR`$NC` testing: \"$filename.rail\". Could not create temporary file for stdout."     fail=$(($fail + 1))     return   fi -  stderrfile=$(mktemp --tmpdir="$TMPDIR" swp14_ci_stderr.XXXXX)+  stderrfile=$(mktemp -t swp14_ci_stderr.XXXXX)   if [ $? -gt 0 ]; then     echo -e "`$red`ERROR`$NC` testing: \"$filename.rail\". Could not create temporary file for stderr."     fail=$(($fail + 1))@@ -135,7 +153,7 @@     TOTAL_TESTCASES=$(($TOTAL_TESTCASES + 1))      # Execute the test!-    echo -ne "${STDIN[$i]}" | do_lli "$TMPDIR/$filename" 1>"$stdoutfile" 2>"$stderrfile"+    echo -ne "${STDIN[$i]}" | run "$filename" 1>"$stdoutfile" 2>"$stderrfile"      # Read stdout and stderr, while converting all actual newlines to \n.     # Really ugly: bash command substitution eats trailing newlines so we@@ -147,8 +165,13 @@     stderr=$(cat "$stderrfile"; echo x)     stderr=${stderr%x}     stderr=${stderr//$'\n'/\\n}--    if [[ "$stdout" == "${STDOUT[$i]}" && "$stderr" == "${STDERR[$i]}" ]]; then+    if [ -n "$fileoutput" ]; then+      echo "$filename - Input: \"${STDIN[$i]}\"" >> "${fileoutput}.tests"+      echo "$stdout" >> "$fileoutput"+      echo "$stderr" >> "${fileoutput}.err"+      echo "${STDOUT[$i]}" >> "${fileoutput}.exp"+      echo "${STDERR[$i]}" >> "${fileoutput}.exp.err"+    elif [[ "$stdout" == "${STDOUT[$i]}" && "$stderr" == "${STDERR[$i]}" ]]; then       [ $verbose -gt 0 ] && echo -n "`$green`Passed`$NC` \"$filename.rail\" with input \"${STDIN[$i]}\"" 	if [ $verbose -gt 1 ]; then           echo "  Got output: \"$stdout\". Stderr: \"$stderr\"."@@ -158,7 +181,7 @@     else       fail=$(($fail + 1))       echo "`$red`ERROR`$NC` testing \"$filename.rail\" with input \"${STDIN[$i]}\"!" \-        "Expected \"${STDOUT[$i]}\" on stdin, got \"$stdout\";" \+        "Expected \"${STDOUT[$i]}\" on stdout, got \"$stdout\";" \         "expected \"${STDERR[$i]}\" on stderr, got \"$stderr\"."     fi   done@@ -177,17 +200,23 @@   done } -### Function to correctly call the LLVM interpreter-function do_lli {+### Function to correctly call the LLVM/java interpreter/rail interpreter+function run {   # On some platforms, the LLVM IR interpreter is not called "lli", but   # something like "lli-x.y", where x.y is the LLVM version -- there may be   # multiple such binaries for different LLVM versions.   # Instead of trying to find the right version, we currently assume that   # such platforms use binfmt_misc to execute LLVM IR files directly (e. g. Ubuntu).-  if command -v lli >/dev/null; then-      lli "$@"+  if [ -n "$cpp" ]; then+    java -cp "$TMPDIR/" "$@"+  elif [ -n "$interpreter" ]; then+    "$INTERPRETER" "$TESTDIR/$@.rail"   else-      "$@"+    if command -v lli >/dev/null; then+        lli "$TMPDIR/$@"+    else+        "$TMPDIR/$@"+    fi   fi } @@ -211,12 +240,12 @@  ### Parse commandline options. verbose=0-test=""-enable=""-disable=""+test=""    # The test to run.+enable=""  # The test to enable.+disable="" # The test to disable.  OPTIND=1-while getopts "hvlre:d:" opt; do+while getopts "hviclre:ad:o:" opt; do   case "$opt" in     h)       show_help@@ -228,6 +257,15 @@     l)       list=true       ;;+    i)+      interpreter=true+      ;;+    c)+      cpp=true+      ;;+    a)+      ast=true+      ;;     r)       reverse=true       ;;@@ -237,6 +275,9 @@     d)       disable=$OPTARG       ;;+    o)+      fileoutput=$OPTARG+      ;;     '?')       show_help >&2       exit 1@@ -245,19 +286,35 @@ done shift "$((OPTIND-1))" # Shift off the options and optional --. test="$1"+# Set fileoutput to absolute path.+if [ -n "$fileoutput" ]; then +  fileoutput="$OLDDIR/$fileoutput"+  if [ -f "$fileoutput" ]; then+    echo "Outpput file exists. Removing."+    rm "$fileoutput"{,.exp,.err,.exp.err}+  fi+fi +# -r implies -v+[[ -n $reverse && $verbose -eq 0 ]] && verbose=1+ ### Checking for incompatible options. count=0+[[ -n $interpreter ]] && count=$(($count + 1))+[[ -n $cpp ]] && count=$(($count + 1)) [[ -n $list ]] && count=$(($count + 1)) [[ -n "$disable" ]] && count=$(($count + 1)) [[ -n "$enable" ]] && count=$(($count + 1)) if (( $count > 1 )); then-  echo "Only specify one of -l, -e, -d."+  echo "Only specify one of -l, -e, -d, -c, -i."   exit 1 fi + ### Main function. TOTAL_TESTCASES=0+CPPCOMPILER=dist/build/RailCompiler/cppRail+INTERPRETER=dist/build/RailCompiler/rail_interpreter  if [ "$reverse" = true ]; then   TESTDIR="integration-tests"@@ -287,17 +344,23 @@   exit 0 fi -TMPDIR=tests/tmp+export TMPDIR=tests/tmp mkdir -p $TMPDIR+ fail=0-if [ -n "$test" ];then-  if [ "${test##*.}" == "rail" ]; then-    # Set the TESTDIR to the directory the .rail file is in.-    test="$OLDDIR"/"$test"-    TESTDIR=${test%/*}+if [ -n "$test" ]; then+  if [ -d "$test" ]; then # Use that directory as TESTDIR+    TESTDIR="$OLDDIR/$test"+    run_all   else-    TESTDIR="integration-tests"-    test=$(get_filename "$test") # Find the path to the specified test+    if [ "${test##*.}" == "rail" ]; then+      # Set the TESTDIR to the directory the .rail file is in.+      test="$OLDDIR"/"$test"+      TESTDIR=${test%/*}+    else+      TESTDIR="integration-tests"+      test=$(get_filename "$test") # Find the path to the specified test+    fi   fi   if [ -f "$test" ]; then     run_one "$test"@@ -307,12 +370,15 @@ else   run_all fi-rm -r tests/tmp +rm -rf tests/tmp+ echo echo "RAN $TOTAL_TESTCASES TESTCASES IN TOTAL."--+if [ -n "$fileoutput" ]; then +  echo "Written outputs to $fileoutput."+  exit 0+fi if [ ! $fail -eq 0 ];then   echo "`$red`FAILED`$NC` $fail test cases."   exit 1