------------------------------------------------------------------------------
-- The ADP Compiler 
-- Copyright (C) 2001-2007 Peter Steffen, Marco Ruether, Christian Lang,
-- Georg Sauthoff
--
-- Send comments/bug reports to: P.Steffen <psteffen@techfak.uni-bielefeld.de>.
-- Updates: http://www.techfak.uni-bielefeld.de/~psteffen/
------------------------------------------------------------------------------

> module TL(

>   MemType(..),
>   TL(..),
>   KWorkersTL(..),

>   WorkersTL,

>   collectDataType,
>   collectTL,
>   collectTLs,
>   collectVAccess,
>   commentBox,
>   commentLn,
>   declToVA,
>   initStack,
>   longComment,
>   longCommentToBox,
>   makeWorkersTL,
>   meToTL, tlvar, tlnumber,
>   pushStack,
>   rev_TL,
>   tlLongComment,
>   tlLongComments,
>   tlNonterm,
>   wrkDataType,
>   wrkTL,
>   wrkTLs,
>   wrkTypeDecl,
>   wrkVAccess,
>   wrkVarDecls,

> ) where

> import Tools
> import MathExp
> import Expr
> import Syntax
> import Dss
> import TLData
> import Constants
> import PrettyPrint

> rev_TL =  "$Revision: 718 $"

%----------------------------------------------------------------------------------------------------
\section{Zielsprache}
%----------------------------------------------------------------------------------------------------

%----------------------------------------------------------------------------------------------------
\subsection{Abstrakte Syntax}
%----------------------------------------------------------------------------------------------------

> data MemType = MTDynamic    -- dynamic memory, handled via malloc/free
>              | MTStatic     -- global memory 
>              | MTTemp       -- temp memory
>                                                             deriving (Eq, Show)


> data TL = 
>   TLNil                                             |
>   TLLayout String                                   |
>   TLComment [String]                                |
>   TLVar VarAccess                                   |  
>   TLDecls [VarDecl]                                 |
>   TLTypeDecls [TypeDecl]                            |
>   TLAssign   VarAccess TL                           |
>   TLAssignIF VarAccess Exp TL TL                    |
>   TLAlloc    MemType VarAccess Exp DataType         |  
>   TLAllocArr VarAccess [(Exp, Exp)]                 |  -- Fortran array allocation
>   TLExp Exp                                         |
>   TLFD  [String] DataType String [VarDecl] [VarDecl] [TL] TL |
>   TLFA  Function [TL]                               |
>   TLFPA VarAccess [TL]                              |
>   TLIf  Exp [TL] [TL]                               |
>   TLIfs Exp [TL] [TL]                               |  -- for large number of alternatives -> better prettyprinting
>   TLIfDef String [TL]                               |
>   TLFor  VarName MathExp MathExp [TL]               | 
>   TLForI VarName MathExp MathExp String [TL]        |  -- for-loop with increment !- 1 
>   TLWhileNN VarAccess [TL]                          |
>   TLWhile   Exp       [TL]                          |
>   TLBreak                                           |
>   TLDefines [(String, [String], [TL])]              |  -- Name, Argumente, Definition
>   TLPrint String [TL]                               |  -- Format-String, Argumente
>   TLBlock [TL]
>                                                             deriving (Eq, Show)


> instance Pretty TL where
>     pretty = ppTLC 0
>     prettyLang C = ppTLC 0
>     prettyLang F = ppTLF 0
>     prettyLang Pascal = ppTLPascal 0



Prettyprinter für Pascal:

> ppTLPascal ind TLNil = "nil"
> ppTLPascal ind (TLLayout l)   = l
> ppTLPascal ind (TLComment cs) = concatMap (\c -> spc ind ++ "// " ++ c ++ "\n") cs
> ppTLPascal ind (TLVar n)   = ppVarAccessPascal n
> ppTLPascal ind (TLDecls ds)  = "var\n" ++ concatMap ppVD ds where
>                                    ppVD v = spc (ind +tlStdInd) ++ ppVarDeclPascal v ++ ";\n"
> ppTLPascal ind (TLTypeDecls ds)  = "type\n" ++ concatMap ppTD ds where
>                                    ppTD v = spc (ind +tlStdInd) ++ ppTypeDeclPascal v ++ ";\n"

> ppTLPascal ind (TLAssign n (TLFA f args)) = spc ind ++ ppVarAccessPascal n ++ " := " ++ ppTLPascal_fa f args ++ ";\n"
> ppTLPascal ind (TLAssign n a)             = spc ind ++ ppVarAccessPascal n ++ " := " ++ ppTLPascal ind a ++ ";\n"
> -- ppTLPascal ind (TLAssign n (TLFPA f args)) = spc ind ++ ppVarAccessPascal n ++ " = " ++ 
> --                                                 ppTLPascal_fa ("(&" ++ ppVarAccessPascal f ++ ")") args ++ ";\n"
> ppTLPascal ind (TLAssignIF n e v1 v2)     = ppTLPascal ind (TLIf e [TLAssign n v1] [TLAssign n v2])
> ppTLPascal ind (TLAlloc _ v e d)   = spc ind ++ "new(" ++ ppVarAccessPascal v ++ ");\n"
> ppTLPascal ind (TLExp m)   = prettyLang Pascal m
> ppTLPascal ind (TLFD cmt rt f params vdecls body rv) = 
>                                        ppTLPascal ind (TLComment cmt) ++ 
>                                        (if rt==TLVoid then "procedure " else "function ") 
>                                        ++ f ++  
>                                        (if (length params)>0 then 
>                                           "(" ++ sepList "; " 
>                                                  (map ppVarDeclPascal params) 
>                                            ++ ")" else []) ++
>                                        (if rt == TLVoid then "" else (":" ++ ppDataTypePascal rt)) ++  
>                                        ";\n" ++
>                                        (if (length vdecls)>0 then "var\n" else "") ++
>                                        (concatMap ppVD vdecls) ++ "\n" ++
>                                        "begin\n" ++
>                                        concatMap (ppTLPascal (ind+tlStdInd)) body ++
>                                        rv' ++  
>                                        "end;\n" where
>                                           ppVD v = spc (ind +tlStdInd) ++ ppVarDeclPascal v ++ ";\n"
>                                           rv' = if rt == TLVoid then [] else 
>                                                    spc (ind +tlStdInd) ++ f ++ " := " ++ ppTLPascal ind rv ++ ";\n"
>                                           
                                           
> ppTLPascal ind (TLFA f args)  = spc ind ++ ppTLPascal_fa f args ++ ";\n"
> ppTLPascal ind (TLIf b t e) = spc ind ++ "if " ++ prettyLang Pascal b ++ " then begin\n" 
>                                 ++ concatMap (ppTLPascal (ind+tlStdInd)) t ++ 
>                                    spc ind ++ "end" 
>                                    ++ if length e == 0 then ";\n" else "\n" ++ spc ind ++ "else begin\n" ++ 
>                                       concatMap (ppTLPascal (ind+tlStdInd)) e ++ spc ind ++  "end;\n"
> ppTLPascal ind (TLIfs b t e) = ppTLPascal ind (TLIf b t e)

> ppTLPascal ind (TLIfDef _ tl) = concatMap (ppTLPascal ind) tl
> ppTLPascal ind (TLFor f b e d) = spc ind ++ "for " ++ f ++ ":=" ++ ppMathExpTL Pascal b ++ direc ++ ppMathExpTL Pascal e ++ 
>                                      " do begin\n" ++ 
>                                           concatMap (ppTLPascal (ind+tlStdInd)) d ++ spc ind ++ "end;\n" 
>                                  where
>                                    direc = if e == (Number 0) then " downto " else " to "

> ppTLPascal ind (TLWhileNN v body) = spc ind ++ "while " ++ ppVarAccessPascal v ++ " <> nil do begin\n" ++ 
>                                            concatMap (ppTLPascal (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "end;\n"
> ppTLPascal ind (TLWhile e body) = spc ind ++ "while " ++ prettyLang Pascal e ++ " do begin\n" ++ 
>                                            concatMap (ppTLPascal (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "end;\n"
> ppTLPascal ind (TLDefines defs) = ppTLDefines ind ppTLPascal defs
> ppTLPascal ind (TLFPA f args) = spc ind ++ ppTLPascal_fa ("(&" ++ ppVarAccessPascal f ++ ")") args ++ ";\n"

> ppTLPascal ind (TLPrint f [TLFA ff args]) = spc ind ++ "write(" ++ ppTLPascal_fa ff args ++ ");\n"
> ppTLPascal ind (TLPrint f args) | args == [] = spc ind ++ "write('" ++ f ++ "');\n"
>                                    | otherwise  = spc ind ++ "write(" ++ mapsep ", " (ppTLPascal ind) args ++ ");\n"
> ppTLPascal ind (TLBlock tls)  = concatMap (ppTLPascal ind) tls

> ppTLPascal_fa f args  = f ++ "(" ++ sepList ", " (map (ppTLPascal 0) args) ++ ")"


Prettyprinter für C:

> ppTLC ind TLNil = "NULL"
> ppTLC ind (TLLayout l)   = l
> ppTLC ind (TLComment cs) = concatMap ppC cs where
>                                ppC c = spc ind ++ "/* " ++ c' ++ " */\n" where
>                                  c' = case c of
>                                        ('-':cs)  -> drop d1 $ take (l-d2) c
>                                        otherwise -> c
>                                  d1 = ind `div` 2
>                                  d2 = ind - d1
>                                  l  = length c
>                                  
> ppTLC ind (TLVar n)  = ppVarAccessC n
> ppTLC ind (TLDecls ds)  =  concatMap ppVD ds where
>                                    ppVD v = spc ind ++ "static " ++ ppVarDeclC v ++ ";\n"
> ppTLC ind (TLTypeDecls ds)  = concatMap ppTypeDeclC ds 

> ppTLC ind (TLAssign n (TLFA f args))      = spc ind ++ ppVarAccessC n ++ " = " ++ ppTLC_fa f                               args ++ ";\n"
> ppTLC ind (TLAssign n (TLFPA f args))     = spc ind ++ ppVarAccessC n ++ " = " ++ ppTLC_fa ("(*" ++ ppVarAccessC f ++ ")") args ++ ";\n"
> ppTLC ind (TLAssign n a)                  = spc ind ++ ppVarAccessC n ++ " = " ++ ppTLC ind a ++ ";\n"
> ppTLC ind (TLAssignIF n e v1 v2)          = spc ind ++ ppVarAccessC n ++ " = " ++ prettyLang C e ++ " ? " ++
>                                                        ppTLC ind v1 ++ " : " ++ ppTLC ind v2 ++ ";\n"
> ppTLC ind (TLAlloc mt v e d)  = spc ind ++ ppVarAccessC v ++ "=(" ++ ppDataTypeC (PointerOf d) ++ ") " ++
>                                 fctname ++ "(" ++ arg ++ mult ++ "sizeof(" ++ ppDataTypeC d ++ "));\n"
>   where 
>     fctname = case mt of
>                    MTDynamic -> "malloc"
>                    otherwise -> "myalloc"
>     arg = case mt of
>                   MTDynamic -> ""
>                   MTStatic  -> "adp_statmem, "
>                   MTTemp    -> "adp_dynmem, "
>     mult  = if e == (ExpNum 1) then "" else "(" ++ prettyLang C e ++ ") * "

> ppTLC ind (TLExp m)   = prettyLang C m
> ppTLC ind (TLFD cmt rt f params vdecls body rv) = 
>                                            ppTLC ind (TLComment cmt) ++ 
>                                            "static " ++ ppDataTypeC rt
>                                            ++ f ++  
>                                            "(" ++ sepList ", " 
>                                                  (map ppVarDeclC params) 
>                                            ++ ")"  ++
>                                           if body == [] then ";\n" else 
>                                        "\n" ++
>                                        "{\n" ++
>                                        (concatMap ppVD vdecls) ++ (if vdecls == [] then "" else "\n") ++
>                                        concatMap (ppTLC (ind+tlStdInd)) body ++
>                                        rv' ++ 
>                                        "}\n" where
>                                           ppVD v = spc (ind +tlStdInd) ++ ppVarDeclC v ++ ";\n"
>                                           rv' = if rt == TLVoid then [] else 
>                                                    spc (ind +tlStdInd) ++ "return(" ++ ppTLC' rv ++ ");\n"
>                                           ppTLC' (TLFA f args) = ppTLC_fa f args 
>                                           ppTLC' x             = ppTLC  ind x
>                                           

> ppTLC ind (TLFA f args)  = spc ind ++ ppTLC_fa f                               args ++ ";\n"
> ppTLC ind (TLFPA f args) = spc ind ++ ppTLC_fa ("(*" ++ ppVarAccessC f ++ ")") args ++ ";\n"

> ppTLC ind (TLIf b t e) = spc ind ++ "if (" ++ prettyLang C b ++ ") {\n" 
>                                  ++ concatMap (ppTLC (ind+tlStdInd)) t ++ 
>                                    spc ind ++ "}" ++ if length e == 0 then "\n" else "\n" ++ spc ind ++ "else {\n" ++ 
>                                    concatMap (ppTLC (ind+tlStdInd)) e ++ spc ind ++  "}\n"
> ppTLC ind (TLIfs b t e) = spc ind ++ "if (" ++ prettyLang C b ++ ") {\n" 
>                                   ++ concatMap (ppTLC (ind+tlStdInd)) t ++ 
>                                    spc ind ++ "}" ++ if length e == 0 then ";\n" else " else \n" ++ 
>                                    concatMap (ppTLC ind) e 
> ppTLC ind (TLIfDef d t) = spc ind ++ "#ifdef " ++ d ++ "\n" ++
>                                   concatMap (ppTLC (ind+tlStdInd)) t ++
>                           spc ind ++ "#endif\n"

> ppTLC ind (TLFor f b e d) = spc ind ++ "for (" ++ f ++ "=" ++ ppMathExpTL C b ++ "; " ++ f ++ direc ++ ppMathExpTL C e ++ "; " ++ f ++ direc' ++ ")" ++ 
>                                      " {\n" ++ 
>                                           concatMap (ppTLC (ind+tlStdInd)) d ++ spc ind ++ "}\n" 
>                                  where
>                                    direc  = if e == (Number 0) then ">=" else "<="
>                                    direc' = if e == (Number 0) then "--" else "++"
> ppTLC ind (TLForI f b e inc d) 
>                           = spc ind ++ "for (" ++ f ++ "=" ++ ppMathExpTL C b ++ "; " ++ f ++ direc ++ ppMathExpTL C e ++ "; " ++ f ++ direc' ++ ")" ++ 
>                                      " {\n" ++ 
>                                           concatMap (ppTLC (ind+tlStdInd)) d ++ spc ind ++ "}\n" 
>                                  where
>                                    direc  = if e == (Number 0) then ">=" else "<="
>                                    direc' = " += " ++ inc 

> ppTLC ind (TLWhileNN v body) = spc ind ++ "while (" ++ ppVarAccessC v ++ " != NULL) {\n" ++ 
>                                            concatMap (ppTLC (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "}\n"

> ppTLC ind (TLWhile e body)   = spc ind ++ "while (" ++ prettyLang C e ++ ") {\n" ++ 
>                                            concatMap (ppTLC (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "}\n"
> ppTLC ind (TLBreak)          = spc ind ++ "break;\n"

> ppTLC ind (TLDefines defs)   = ppTLDefines ind ppTLC defs

> ppTLC ind (TLPrint f [TLFA ff args]) = spc ind ++ "printf(\"" ++ f ++ "\", " ++ ppTLC_fa ff args ++ ");\n"
> ppTLC ind (TLPrint f args) | args == [] = spc ind ++ "printf(\"" ++ f ++ "\");\n"
>                               | otherwise  = spc ind ++ "printf(\"" ++ f ++ "\", " ++ mapsep ", " (ppTLC ind) args ++ ");\n"
> ppTLC ind (TLBlock tls)  = concatMap (ppTLC ind) tls

> ppTLC_fa f args  = f ++ "(" ++ sepList ", " (map (ppTLC' 0) args) ++ ")"
>   where
>     ppTLC' 0 (TLFA f args) = ppTLC_fa f args
>     ppTLC' 0 x             = ppTLC 0 x

Prettyprinter für Fortran:

> ppTLF ind TLNil = "NULL"
> ppTLF ind (TLLayout l)   = l
> ppTLF ind (TLComment cs) = concatMap ppF cs where
>                                ppF c = spc ind ++ "! " ++ c' ++ " !\n" where
>                                  c' = case c of
>                                        ('-':cs)  -> drop d1 $ take (l-d2) c
>                                        otherwise -> c
>                                  d1 = ind `div` 2
>                                  d2 = ind - d1
>                                  l  = length c
>                                  
> ppTLF ind (TLVar n)  = ppVarAccessF n
> ppTLF ind (TLDecls ds)  =  concatMap ppVD ds where
>                                    ppVD v = spc ind ++ ppVarDeclF v ++ "\n"
> ppTLF ind (TLTypeDecls ds)  = concatMap ppTypeDeclF ds 

> ppTLF ind (TLAssign n (TLFA f args))      = spc ind ++ ppVarAccessF n ++ " = " ++ ppTLF_fa f                               args ++ "\n"
> ppTLF ind (TLAssign n (TLFPA f args))     = spc ind ++ ppVarAccessF n ++ " = " ++ ppTLF_fa ("(*" ++ ppVarAccessF f ++ ")") args ++ "\n"
> ppTLF ind (TLAssign n a)                  = spc ind ++ ppVarAccessF n ++ " = " ++ ppTLF ind a ++ "\n"
> ppTLF ind (TLAssignIF n e v1 v2)          = spc ind ++ ppVarAccessF n ++ " = " ++ 
>                                                           "MERGE(" ++ ppTLF ind v1 ++ " , " ++ ppTLF ind v2 ++ " , " ++ prettyLang F e ++ ")"
>                                                           ++ "\n"

> ppTLF ind (TLAlloc _ v e d)  = spc ind ++ "ALLOCATE(" ++ ppVarAccessF v ++ "(0 : " ++ prettyLang F (ExpME $ size :- (Number 1)) ++ "))\n" 
>       where size = case e of
>                         ExpME s  -> s
>                         otherwise -> error $ "ppTLF: unknown table dimension: " ++ show e
> ppTLF ind (TLAllocArr v dims) = spc ind ++ "ALLOCATE(" ++ ppVarAccessF v ++ "(" ++ mapsep ", " ppDim dims ++ "))\n"
>       where ppDim (b,e) = prettyLang F b ++ " : " ++ prettyLang F e

> ppTLF ind (TLExp m)   = prettyLang F m
> ppTLF ind (TLFD cmt rt f params vdecls body rv) = 
>                                        ppTLF ind (TLComment cmt) ++ 
>                                        (if procedure then "SUBROUTINE " else "FUNCTION ") 
>                                        ++ f
>                                        ++ "(" ++  sepList ", " (concatMap fst params) ++ ")"  ++
>                                        (if procedure then "" else " RESULT(" ++ resultVar ++ ")" ) 
>                                        ++ "\n" ++
>                                        spc (ind +tlStdInd) ++ "IMPLICIT NONE\n" ++
>                                        (concatMap ppVD params) ++ "\n" ++
>                                        (if procedure then "" else ppVD ([resultVar], rt) ++ "\n") ++
>                                        (concatMap ppVD vdecls) ++ (if vdecls == [] then "" else "\n") ++
>                                        concatMap (ppTLF (ind+tlStdInd)) body ++
>                                        rv' ++ 
>                                        "END SUBROUTINE\n" 
>                                        where
>                                           procedure = rt==TLVoid
>                                           resultVar = "RES_" ++ f
>                                           ppVD v = spc (ind +tlStdInd) ++ ppVarDeclF v ++ "\n"
>                                           rv' = if rt == TLVoid then [] else 
>                                                    spc (ind +tlStdInd) ++ resultVar ++ " = " ++ ppTLF' rv ++ "\n"
>                                           ppTLF' (TLFA f args) = ppTLF_fa f args 
>                                           ppTLF' x             = ppTLF  ind x
>                                           

> ppTLF ind (TLFA f args)  = spc ind ++ "CALL " ++ ppTLF_fa f                    args ++ "\n"
> ppTLF ind (TLFPA f args) = spc ind ++ ppTLF_fa ("(*" ++ ppVarAccessF f ++ ")") args ++ "\n"

> ppTLF ind (TLIf b t e) = spc ind ++ "IF (" ++ prettyLang F b ++ ") THEN\n" 
>                                  ++ concatMap (ppTLF (ind+tlStdInd)) t ++ 
>                                    spc ind ++ if length e == 0 then "END IF\n" else "\n" ++ spc ind ++ "ELSE \n" ++ 
>                                    concatMap (ppTLF (ind+tlStdInd)) e ++ spc ind ++  "END IF\n"
> ppTLF ind (TLIfs b t e) = spc ind ++ "IF (" ++ prettyLang F b ++ ") THEN\n" 
>                                   ++ concatMap (ppTLF (ind+tlStdInd)) t ++ 
>                                    spc ind ++ if length e == 0 then "END IF\n" else "ELSE\n" ++ 
>                                    concatMap (ppTLF ind) e 
> ppTLF ind (TLIfDef d t) = spc ind ++ "#ifdef " ++ d ++ "\n" ++
>                                   concatMap (ppTLF (ind+tlStdInd)) t ++
>                           spc ind ++ "#endif\n"

> ppTLF ind (TLFor f b e d) = spc ind ++ "DO " ++ f ++ "=" ++ ppMathExpTL F b ++ ", " ++ ppMathExpTL F e ++ ", " ++ direc ++ "\n" ++
>                                       concatMap (ppTLF (ind+tlStdInd)) d ++ spc ind ++ "END DO\n" 
>                                  where
>                                    direc = if e == (Number 0) then "-1" else "1"

> ppTLF ind (TLWhileNN v body) = spc ind ++ "while (" ++ ppVarAccessF v ++ " != NULL) {\n" ++ 
>                                            concatMap (ppTLF (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "}\n"

> ppTLF ind (TLWhile e body)   = spc ind ++ "while (" ++ prettyLang F e ++ ") {\n" ++ 
>                                            concatMap (ppTLF (ind+tlStdInd)) body ++ 
>                                   spc ind ++ "}\n"

> ppTLF ind (TLDefines defs)   = ppTLDefines ind ppTLF defs

> ppTLF ind (TLPrint f [TLFA ff args]) = spc ind ++ "PRINT*, (" ++ ppTLF_fa ff args ++ ")\n"
> ppTLF ind (TLPrint f args) | args == [] && f == "\\n" = spc ind ++ "PRINT*\n"
>                               | args == []               = spc ind ++ "PRINT*, '" ++ f ++ "'\n"
>                               | otherwise                = spc ind ++ "PRINT*, (" ++ mapsep ", " (ppTLF ind) args ++ ")\n"
> ppTLF ind (TLBlock tls)  = concatMap (ppTLF ind) tls

> ppTLF_fa f args  = f ++ "(" ++ sepList ", " (map (ppTLF' 0) args) ++ ")"
>   where
>     ppTLF' 0 (TLFA f args) = ppTLF_fa f args
>     ppTLF' 0 x             = ppTLF 0 x

Alle Zielsprachen: 

> ppTLDefines ind pp defs = concatMap ppDef defs where
>                                    ppDef (n,args,tls) = spc ind ++ "#define " ++ n ++ optArgs ++ " " ++ def ++ "\n"
>                                      where optArgs | args == [] = "" 
>                                                    | otherwise  = "(" ++ sepList ", " args ++ ")"
>                                            def     | length tls == 1  = pp ind $ head tls
>                                                    | otherwise        = "\n" ++ mapsep "\n\\" (pp $ ind + tlStdInd) tls


Wrapper-Funktion:

> ppTL :: Output -> TL -> String
> ppTL C       = ppTLC 0
> ppTL F       = ppTLF 0
> ppTL Pascal  = ppTLPascal 0

-------------------------------------------------------------------------
prettyprinter fuer MathExp - modifiziert fuer lookahead-Tabellenzugriffe:

> ppMathExpTL tl m             = ppMathExpTL' tl (calcME m)
> ppMathExpTL' tl Infinite     = "Infinite"
> ppMathExpTL' tl (Number a)   = show a
> ppMathExpTL' tl (Var a)      = a

> ppMathExpTL' tl (a :+ b)     = ppMathExpTL' tl a ++ "+" ++ ppMathExpTL' tl b
> ppMathExpTL' tl (a :* b)     = a' ++ "*" ++ b' 
>                           where
>                             a' = if atomarME a then ppMathExpTL' tl a else "(" ++ ppMathExpTL' tl a ++ ")"
>                             b' = if atomarME b then ppMathExpTL' tl b else "(" ++ ppMathExpTL' tl b ++ ")"
> ppMathExpTL' tl (a :/ b)     = a' ++ "/" ++ b' 
>                           where
>                             a' = if atomarME a then ppMathExpTL' tl a else "(" ++ ppMathExpTL' tl a ++ ")"
>                             b' = if atomarME b then ppMathExpTL' tl b else "(" ++ ppMathExpTL' tl b ++ ")"


> ppMathExpTL' tl (a :- b)     = ppMathExpTL' tl a ++ "-" ++ b' 
>                           where
>                             b' = if atomarME b then ppMathExpTL' tl b else "(" ++ ppMathExpTL' tl b ++ ")"

> ppMathExpTL' tl (Max a b)         = "max(" ++ ppMathExpTL' tl a ++ ", " ++ ppMathExpTL' tl b ++ ")"
> ppMathExpTL' tl (Min a b)         = "min(" ++ ppMathExpTL' tl a ++ ", " ++ ppMathExpTL' tl b ++ ")"

> ppMathExpTL' C (LA f LAL (i, j))      = prettyLang C      (ArrayElem [i, j, Number 0] (Direct f))
> ppMathExpTL' C (LA f LAU (i, j))      = prettyLang C      (ArrayElem [i, j, Number 1] (Direct f))
> ppMathExpTL' F (LA f LAL (i, j))      = prettyLang F      (ArrayElem [i, j, Number 0] (Direct f))
> ppMathExpTL' F (LA f LAU (i, j))      = prettyLang F      (ArrayElem [i, j, Number 1] (Direct f))
> ppMathExpTL' Pascal (LA f LAL (i, j)) = prettyLang Pascal (ArrayElem [i, j, Number 0] (Direct f))
> ppMathExpTL' Pascal (LA f LAU (i, j)) = prettyLang Pascal (ArrayElem [i, j, Number 1] (Direct f))

> ppMathExpTL' C      (Offset s)        = prettyLang C      (ArrayElem [s] (Direct (poffset prefixes)))
> ppMathExpTL' F      (Offset s)        = prettyLang F      (ArrayElem [s] (Direct (poffset prefixes)))
> ppMathExpTL' Pascal (Offset s)        = prettyLang Pascal (ArrayElem [s] (Direct (poffset prefixes)))

-------------------------------------------------------------------------

Tools:
------

> longComment s = [s ++ replicate (max 0 ((commentWidth - length s))) ' ', (replicate commentWidth '-')]

> tlLongComment :: String -> TL
> tlLongComment s = TLComment $ longComment s

> tlLongComments :: [String] -> TL
> tlLongComments s = TLComment $ map (\s -> s ++ replicate (max 0 ((commentWidth - length s))) ' ') s ++ [(replicate commentWidth '-')]

> commentLn s = TLComment [p1 ++ " " ++ s ++ " " ++ p2]
>   where
>     l   = (commentWidth - 2 - length s)
>     p1  = replicate (max 0 (l `div` 2)) '-'
>     p2  = replicate (max 0 ((l `div` 2) + (l `mod` 2))) '-'

> commentBox s | s == []   = TLComment [] 
>              | otherwise = TLComment $ p ++ map fill s ++ p 
>    where 
>      p = ["+" ++ replicate (w - 1) '-']
>      fill s = s ++ (replicate (max 0 (w - length s)) ' ')
>      w = maximum (map length s) + 10

> longCommentToBox [] = TLComment []
> longCommentToBox cs = commentBox $ [""] ++ init cs ++ [""]


> meToTL m   = TLExp $ ExpME m
> tlvar va   = TLVar $ toVA va
> tlnumber n = TLExp $ ExpNum n

> declToVA [([n], dt)] = (Direct n, dt)
> declToVA x           = pattErr "declToVA" x

> tlNonterm n s = TLVar (VANonterm n s, TLVoid)

Stack
------

> stackVar = "stack"
> topStack = "top"
> pushStack v = TLAssign (toVA (Pointer (PreInc (Direct topStack)))) v
> popStack = tlvar (Pointer (PostDec (Direct topStack)))
> initStack = TLAssign (toVA (Direct topStack)) (tlvar (Direct stackVar))



> --------------------------------------------------------------------------------------------------------------------------
> --------------------------------------------------------------------------------------------------------------------------
> -- TL-Traversierung
> -----------------------------------------------

> type WorkersTL cll = (
>   cll -> TL         -> (cll, TL),
>   cll -> [TL]       -> (cll, [TL]),
>   cll -> [VarDecl]  -> (cll, [VarDecl]),
>   cll -> VarAccess  -> (cll, VarAccess),
>   cll -> VAccess    -> (cll, VAccess),
>   cll -> DataType   -> (cll, DataType),
>   cll -> TypeDecl   -> (cll, TypeDecl)
>   )

> wrkTL        (a,_,_,_,_,_,_) = a
> wrkTLs       (_,a,_,_,_,_,_) = a
> wrkVarDecls  (_,_,a,_,_,_,_) = a
> wrkVarAccess (_,_,_,a,_,_,_) = a
> wrkVAccess   (_,_,_,_,a,_,_) = a
> wrkDataType  (_,_,_,_,_,a,_) = a
> wrkTypeDecl  (_,_,_,_,_,_,a) = a

> -- helper for VAccess embedded in Expr
> wrkExp wrk cll (ExpTLVar va) = (cll', ExpTLVar va') 
>    where 
>     (cll', va') = wrkVAccess wrk cll va
> wrkExp wrk cll x = collectExp (wrkExp wrk) cll x

> ------------------------------------------------------------------------------------------
> -- collector for TL
> -------------------------------------
> collectTL wrk cll TLNil = (cll, TLNil)
> collectTL wrk cll (TLLayout a) = (cll, TLLayout a)
> collectTL wrk cll (TLComment a) = (cll, TLComment a)
> collectTL wrk cll (TLVar a)    = (cll', TLVar a')    where (cll', a')  = wrkVarAccess wrk cll a
> collectTL wrk cll (TLDecls ds) = (cll', TLDecls ds') where (cll', ds') = wrkVarDecls wrk cll ds
> collectTL wrk cll (TLTypeDecls td) = (cll', TLTypeDecls td') 
>                                where (cll', td') = collectTypeDecls wrk cll td
> collectTL wrk cll (TLAssign va tl) = (cll'', TLAssign va' tl')
>                                where
>                                  (cll',  va') = wrkVarAccess wrk cll  va
>                                  (cll'', tl') = wrkTL wrk   cll' tl
> collectTL wrk cll (TLAssignIF va e tl1 tl2) = (cll'''', TLAssignIF va' e' tl1' tl2')
>                                where
>                                  (cll',     va') = wrkVarAccess wrk cll    va
>                                  (cll'',     e') = wrkExp       wrk cll'   e
>                                  (cll''',  tl1') = wrkTL        wrk cll''  tl1
>                                  (cll'''', tl2') = wrkTL        wrk cll''' tl2
> collectTL wrk cll (TLAlloc mm va e dt) = (cll''', TLAlloc mm va' e' dt')
>                                where
>                                  (cll',   va') = wrkVarAccess wrk cll   va
>                                  (cll'',  e')  = wrkExp       wrk cll'  e
>                                  (cll''', dt') = wrkDataType  wrk cll'' dt
> collectTL wrk cll (TLAllocArr va dims) = (cll'', TLAllocArr va' dims')
>                                where
>                                  (cll',   va')  = wrkVarAccess wrk cll  va
>                                  (cll'', dims') = wrkDims      wrk cll' dims
>                                  wrkDims wrk cll []             = (cll, [])
>                                  wrkDims wrk cll ((e1,e2):dims) = (cll''', (e1', e2'): dims')
>                                    where
>                                      (cll',  e1')    = wrkExp  wrk cll   e1
>                                      (cll'', e2')    = wrkExp  wrk cll'  e2
>                                      (cll''', dims') = wrkDims wrk cll'' dims
> collectTL wrk cll (TLExp e) = (cll', TLExp e') where (cll', e')  = wrkExp wrk cll e
> collectTL wrk cll (TLFD cmt dt na ds1 ds2 tls tl) = (cll5, TLFD cmt dt' na ds1' ds2' tls' tl')
>                                where
>                                  (cll1, dt')  = wrkDataType wrk  cll  dt
>                                  (cll2, ds1') = wrkVarDecls wrk  cll1 ds1
>                                  (cll3, ds2') = wrkVarDecls wrk  cll2 ds2
>                                  (cll4, tls') = wrkTLs wrk       cll3 tls
>                                  (cll5, tl')  = wrkTL wrk        cll4 tl

> collectTL wrk cll (TLFA f tls) = (cll', TLFA f tls')
>                             where (cll', tls') = wrkTLs wrk cll tls
> collectTL wrk cll (TLFPA va tls) = (cll'', TLFPA va' tls')
>                             where 
>                               (cll',  va')  = wrkVarAccess wrk  cll  va
>                               (cll'', tls') = wrkTLs wrk cll' tls
> collectTL wrk cll (TLIf e tls1 tls2) = (cll''', TLIf e' tls1' tls2')
>                             where
>                               (cll',   e')    = wrkExp     wrk cll   e
>                               (cll'',  tls1') = wrkTLs wrk cll'  tls1
>                               (cll''', tls2') = wrkTLs wrk cll'' tls2
> collectTL wrk cll (TLIfs e tls1 tls2) = (cll''', TLIfs e' tls1' tls2')
>                             where
>                               (cll',   e')    = wrkExp     wrk cll   e
>                               (cll'',  tls1') = wrkTLs wrk cll'  tls1
>                               (cll''', tls2') = wrkTLs wrk cll'' tls2
> collectTL wrk cll (TLFor v a b tls) = (cll', TLFor v a b tls') where (cll', tls') = wrkTLs wrk cll tls
> collectTL wrk cll (TLForI v a b i tls) = (cll', TLForI v a b i tls') where (cll', tls') = wrkTLs wrk cll tls
> collectTL wrk cll (TLWhileNN va tls) = (cll'', TLWhileNN va' tls')
>                             where
>                               (cll',  va')  = wrkVarAccess wrk  cll  va
>                               (cll'', tls') = wrkTLs wrk cll' tls
> collectTL wrk cll (TLWhile e tls) = (cll'', TLWhile e' tls')
>                             where
>                               (cll',   e')  = wrkExp     wrk cll   e
>                               (cll'', tls') = wrkTLs wrk cll' tls
> collectTL wrk cll (TLBreak) = (cll, TLBreak)
> collectTL wrk cll (TLDefines defs) = (cll', TLDefines defs')
>                             where
>                               (cll', defs')        = collectDefines cll defs
>                               collectDefines cll []  = (cll, [])
>                               collectDefines cll ((nm, args, tls):ds) = (cll'', (nm, args, tls'):ds')
>                                 where
>                                   (cll',  tls') = wrkTLs wrk cll tls
>                                   (cll'', ds' ) = collectDefines cll' ds
> collectTL wrk cll (TLPrint f tls) = (cll', TLPrint f tls')
>                             where (cll', tls') = wrkTLs wrk cll tls
> collectTL wrk cll (TLBlock tls)   = (cll', TLBlock tls')
>                             where (cll', tls') = wrkTLs wrk cll tls

> collectTL wrk cll x  =  pattErr "collectTL" x


> ------------------------------------------------------------------------------------------
> -- collector for [TL]
> -------------------------------------
> collectTLs wrk cll []       = (cll, [])
> collectTLs wrk cll (tl:tls) = (cll'', (tl':tls'))
>     where
>       (cll',  tl')  = wrkTL  wrk cll  tl
>       (cll'', tls') = wrkTLs wrk cll' tls

> ------------------------------------------------------------------------------------------
> -- collector for [VarDecl]
> -------------------------------------
> collectVarDecls wrk cll [] = (cll, [])
> collectVarDecls wrk cll ((na,dt):ds) = (cll'', ((na, dt'): ds'))
>     where
>       (cll',  dt') = wrkDataType wrk cll  dt
>       (cll'', ds') = wrkVarDecls wrk cll' ds


> ------------------------------------------------------------------------------------------
> -- collector for VarAccess
> -------------------------------------
> collectVarAccess wrk cll (va, dt) = (cll'', (va', dt'))
>   where
>     (cll',  va') = wrkVAccess wrk cll  va
>     (cll'', dt') = wrkDataType wrk  cll' dt
  

> ------------------------------------------------------------------------------------------
> -- collector for VAccess
> -------------------------------------
> collectVAccess wrk cll (Direct s)  = (cll, Direct s)
> collectVAccess wrk cll (Pointer p) = (cll', Pointer p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (v1 :. v2)  = (cll'', v1' :. v2')
>                                where
>                                  (cll',  v1') = wrkVAccess wrk cll  v1
>                                  (cll'', v2') = wrkVAccess wrk cll' v2
> collectVAccess wrk cll (ArrayElem e va) =  (cll', ArrayElem e va') where (cll', va') = wrkVAccess wrk cll va
> collectVAccess wrk cll (Cast dt va)     =  (cll'', Cast dt' va')
>                                where
>                                  (cll',  dt') = wrkDataType wrk  cll  dt
>                                  (cll'', va') = wrkVAccess wrk cll' va
> collectVAccess wrk cll (Address p) = (cll', Address p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (PreInc p)  = (cll', PreInc  p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (PreDec p)  = (cll', PreDec  p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (PostInc p) = (cll', PostInc p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (PostDec p) = (cll', PostDec p') where (cll', p') = wrkVAccess wrk cll p
> collectVAccess wrk cll (VANonterm nt s) = (cll,VANonterm nt s)
> -- collectVAccess wrk cll x = pattErr "collectVAccess" x

> ------------------------------------------------------------------------------------------
> -- collector for DataType
> -------------------------------------
> collectDataType wrk cll (PointerOf dt)    = (cll', PointerOf dt')    where (cll', dt') = wrkDataType wrk cll dt
> collectDataType wrk cll (Array e dt)      = (cll', Array e dt')      where (cll', dt') = wrkDataType wrk cll dt
> -- adts momentan nur atomare Typen, sonst hier auch Verarbeitung:
> collectDataType wrk cll (FPointer adts dt) = (cll', FPointer adts dt') where (cll', dt') = wrkDataType wrk cll dt  
> collectDataType wrk cll (StructOf na strct) = (cll', StructOf na strct') where
>                                              (cll', strct') = collectStruct wrk cll strct
>                                              collectStruct wrk cll []     = (cll, [])
>                                              collectStruct wrk cll ((n,dt):ss) = (cll'', (n, dt'):ss')
>                                                 where
>                                                   (cll', dt')  = wrkDataType   wrk cll dt
>                                                   (cll'', ss') = collectStruct wrk cll' ss

> collectDataType wrk cll x               = (cll, x)


> ------------------------------------------------------------------------------------------
> -- collector for [TypeDecl]
> -------------------------------------
> collectTypeDecls wrk cll []       = (cll, [])
> collectTypeDecls wrk cll (td:tds) = (cll'', (td':tds'))
>     where
>       (cll',  td')  = wrkTypeDecl wrk  cll  td
>       (cll'', tds') = collectTypeDecls wrk cll' tds


> ------------------------------------------------------------------------------------------
> -- collector for TypeDecl
> -------------------------------------
> collectTypeDecl wrk cll (TypeDef name dt) = (cll', TypeDef name dt')
>       where (cll', dt') = wrkDataType wrk cll dt
> collectTypeDecl wrk cll (StructDecl name vds) = (cll', StructDecl name vds')
>       where (cll', vds') = wrkVarDecls wrk cll vds


> ------------------------------------------------------------------------------------------
> -- helper for WorkersTL construction
> ----------------------------------------
> data KWorkersTL a = NOP | DO a
> makeWorkersTL worker (wrkTL, wrkTLs, wrkVarDecls, wrkVarAccess, wrkVAccess, wrkDataType, wrkTypeDecl) =
>       (m collectTL        wrkTL, 
>        m collectTLs       wrkTLs, 
>        m collectVarDecls  wrkVarDecls, 
>        m collectVarAccess wrkVarAccess, 
>        m collectVAccess   wrkVAccess, 
>        m collectDataType  wrkDataType, 
>        m collectTypeDecl  wrkTypeDecl)
>        where
>          m collector NOP    = collector worker
>          m collector (DO f) = f
