strip PAS2C, old WEB symbols and outdated pas2c sources from default branch, all c-related development is done on the webgl branch
--- a/hedgewars/GSHandlers.inc Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/GSHandlers.inc Wed Apr 03 23:56:59 2013 +0200
@@ -173,23 +173,11 @@
land: word;
begin
// clip velocity at 2 - over 1 per pixel, but really shouldn't cause many actual problems.
-{$IFNDEF WEB}
if Gear^.dX.Round > 2 then
Gear^.dX.QWordValue:= 8589934592;
if Gear^.dY.Round > 2 then
Gear^.dY.QWordValue:= 8589934592;
-{$ELSE}
- if Gear^.dX.Round > 2 then
- begin
- Gear^.dX.Round:= 2;
- Gear^.dX.Frac:= 0
- end;
- if Gear^.dY.QWordValue > 2 then
- begin
- Gear^.dY.Round:= 2;
- Gear^.dY.Frac:= 0
- end;
-{$ENDIF}
+
Gear^.State := Gear^.State and (not gstCollision);
collV := 0;
collH := 0;
--- a/hedgewars/LuaPas.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/LuaPas.pas Wed Apr 03 23:56:59 2013 +0200
@@ -15,9 +15,7 @@
{.$DEFINE LUA_GETHOOK}
type
-{$IFNDEF PAS2C}
size_t = Cardinal;
-{$ENDIF}
Psize_t = ^size_t;
PPointer = ^Pointer;
--- a/hedgewars/hwengine.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/hwengine.pas Wed Apr 03 23:56:59 2013 +0200
@@ -122,11 +122,7 @@
if flagMakeCapture then
begin
flagMakeCapture:= false;
- {$IFDEF PAS2C}
- s:= '/Screenshots/hw';
- {$ELSE}
s:= '/Screenshots/hw_' + FormatDateTime('YYYY-MM-DD_HH-mm-ss', Now()) + inttostr(GameTicks);
- {$ENDIF}
// flash
playSound(sndShutter);
--- a/hedgewars/options.inc Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/options.inc Wed Apr 03 23:56:59 2013 +0200
@@ -66,14 +66,12 @@
{$DEFINE SDL13}
{$ENDIF}
-{$IFDEF PAS2C}
- {$DEFINE NOCONSOLE}
- {$DEFINE USE_SDLTHREADS}
-{$ENDIF}
+//TODO: cruft to be removed
{$DEFINE _S:=}
{$DEFINE _P:=}
+
//{$DEFINE TRACEAIACTIONS}
//{$DEFINE COUNTTICKS}
--- a/hedgewars/uConsts.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/uConsts.pas Wed Apr 03 23:56:59 2013 +0200
@@ -115,13 +115,11 @@
MAXNAMELEN = 192;
MAXROPEPOINTS = 3840;
- {$IFNDEF PAS2C}
// some opengl headers do not have these macros
GL_BGR = $80E0;
GL_BGRA = $80E1;
GL_CLAMP_TO_EDGE = $812F;
GL_TEXTURE_PRIORITY = $8066;
- {$ENDIF}
cVisibleWater : LongInt = 128;
cTeamHealthWidth : LongInt = 128;
--- a/hedgewars/uFloat.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/uFloat.pas Wed Apr 03 23:56:59 2013 +0200
@@ -63,9 +63,7 @@
// The implemented operators
operator = (const z1, z2: hwFloat) z : boolean; inline;
-{$IFDEF PAS2C}
-operator <> (const z1, z2: hwFloat) z : boolean; inline;
-{$ENDIF}
+
operator + (const z1, z2: hwFloat) z : hwFloat; inline;
operator - (const z1, z2: hwFloat) z : hwFloat; inline;
operator - (const z1: hwFloat) z : hwFloat; inline;
@@ -221,19 +219,11 @@
hwFloat2Float:= -hwFloat2Float;
end;
-{$IFNDEF WEB}
operator = (const z1, z2: hwFloat) z : boolean; inline;
begin
z:= (z1.isNegative = z2.isNegative) and (z1.QWordValue = z2.QWordValue);
end;
-{$IFDEF PAS2C}
-operator <> (const z1, z2: hwFloat) z : boolean; inline;
-begin
- z:= (z1.isNegative <> z2.isNegative) or (z1.QWordValue <> z2.QWordValue);
-end;
-{$ENDIF}
-
operator + (const z1, z2: hwFloat) z : hwFloat; inline;
begin
if z1.isNegative = z2.isNegative then
@@ -300,102 +290,6 @@
else
b:= (z1.QWordValue > z2.QWordValue) <> z2.isNegative
end;
-{$ENDIF}
-{$IFDEF WEB}
-(*
- Mostly to be kind to JS as of 2012-08-27 where there is no int64/uint64. This may change though.
-*)
-operator = (const z1, z2: hwFloat) z : boolean; inline;
-begin
- z:= (z1.isNegative = z2.isNegative) and (z1.Frac = z2.Frac) and (z1.Round = z2.Round);
-end;
-
-operator <> (const z1, z2: hwFloat) z : boolean; inline;
-begin
- z:= (z1.isNegative <> z2.isNegative) or (z1.Frac <> z2.Frac) or (z1.Round <> z2.Round);
-end;
-
-operator + (const z1, z2: hwFloat) z : hwFloat; inline;
-begin
-if z1.isNegative = z2.isNegative then
- begin
- z:= z1;
- z.Frac:= z.Frac + z2.Frac;
- z.Round:= z.Round + z2.Round;
- if z.Frac<z1.Frac then inc(z.Round)
- end
-else
- if (z1.Round > z2.Round) or ((z1.Round = z2.Round) and (z1.Frac > z2.Frac)) then
- begin
- z.isNegative:= z1.isNegative;
- z.Round:= z1.Round - z2.Round;
- z.Frac:= z1.Frac - z2.Frac;
- if z2.Frac > z1.Frac then dec(z.Round)
- end
- else
- begin
- z.isNegative:= z2.isNegative;
- z.Round:= z2.Round - z1.Round;
- z.Frac:= z2.Frac-z1.Frac;
- if z2.Frac < z1.Frac then dec(z.Round)
- end
-end;
-
-operator - (const z1, z2: hwFloat) z : hwFloat; inline;
-begin
-if z1.isNegative = z2.isNegative then
- if (z1.Round > z2.Round) or ((z1.Round = z2.Round) and (z1.Frac > z2.Frac)) then
- begin
- z.isNegative:= z1.isNegative;
- z.Round:= z1.Round - z2.Round;
- z.Frac:= z1.Frac-z2.Frac;
- if z2.Frac > z1.Frac then dec(z.Round)
- end
- else
- begin
- z.isNegative:= not z2.isNegative;
- z.Round:= z2.Round - z1.Round;
- z.Frac:= z2.Frac-z1.Frac;
- if z2.Frac < z1.Frac then dec(z.Round)
- end
-else
- begin
- z:= z1;
- z.Frac:= z.Frac + z2.Frac;
- z.Round:= z.Round + z2.Round;
- if z.Frac<z1.Frac then inc(z.Round)
- end
-end;
-
-operator < (const z1, z2: hwFloat) b : boolean; inline;
-begin
-if z1.isNegative xor z2.isNegative then
- b:= z1.isNegative
-else
-(* Not so sure this specialcase is a win w/ Round/Frac. have to do more tests anyway.
- if (z1.Round = z2.Round and (z1.Frac = z2.Frac)) then
- b:= false
- else *)
- b:= ((z1.Round < z2.Round) or ((z1.Round = z2.Round) and (z1.Frac < z2.Frac))) <> z1.isNegative
-end;
-
-operator > (const z1, z2: hwFloat) b : boolean; inline;
-begin
-if z1.isNegative xor z2.isNegative then
- b:= z2.isNegative
-else
-(*
- if z1.QWordValue = z2.QWordValue then
- b:= false
- else*)
- b:= ((z1.Round > z2.Round) or ((z1.Round = z2.Round) and (z1.Frac > z2.Frac))) <> z1.isNegative
-end;
-
-function isZero(const z: hwFloat): boolean; inline;
-begin
-isZero := (z.Round = 0) and (z.Frac = 0);
-end;
-{$ENDIF}
operator - (const z1: hwFloat) z : hwFloat; inline;
begin
--- a/hedgewars/uStore.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/uStore.pas Wed Apr 03 23:56:59 2013 +0200
@@ -21,7 +21,7 @@
unit uStore;
interface
-uses {$IFNDEF PAS2C} StrUtils, {$ENDIF}SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat;
+uses StrUtils, SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat;
procedure initModule;
procedure freeModule;
@@ -765,7 +765,7 @@
AddFileLog(' |----- Number of auxiliary buffers: ' + inttostr(AuxBufNum));
{$ENDIF}
AddFileLog(' \----- Extensions: ');
-{$IFNDEF PAS2C}
+
// fetch extentions and store them in string
tmpstr := StrPas(PChar(glGetString(GL_EXTENSIONS)));
tmpn := WordCount(tmpstr, [' ']);
@@ -783,10 +783,6 @@
tmpint := tmpint + 3;
end;
until (tmpint > tmpn);
-{$ELSE}
- // doesn't seem to print >256 chars
- AddFileLogRaw(PChar(glGetString(GL_EXTENSIONS)));
-{$ENDIF}
AddFileLog('');
defaultFrame:= 0;
--- a/hedgewars/uUtils.pas Wed Apr 03 00:46:19 2013 +0200
+++ b/hedgewars/uUtils.pas Wed Apr 03 23:56:59 2013 +0200
@@ -27,14 +27,12 @@
procedure SplitByChar(var a, b: shortstring; c: char);
procedure SplitByChar(var a, b: ansistring; c: char);
-{$IFNDEF PAS2C}
function EnumToStr(const en : TGearType) : shortstring; overload;
function EnumToStr(const en : TVisualGearType) : shortstring; overload;
function EnumToStr(const en : TSound) : shortstring; overload;
function EnumToStr(const en : TAmmoType) : shortstring; overload;
function EnumToStr(const en : THogEffect) : shortstring; overload;
function EnumToStr(const en : TCapGroup) : shortstring; overload;
-{$ENDIF}
function Min(a, b: LongInt): LongInt; inline;
function Max(a, b: LongInt): LongInt; inline;
@@ -68,10 +66,8 @@
function GetLaunchX(at: TAmmoType; dir: LongInt; angle: LongInt): LongInt;
function GetLaunchY(at: TAmmoType; angle: LongInt): LongInt;
-{$IFNDEF PAS2C}
procedure Write(var f: textfile; s: shortstring);
procedure WriteLn(var f: textfile; s: shortstring);
-{$ENDIF}
function isPhone: Boolean; inline;
function getScreenDPI: Double; inline; //cdecl; external;
@@ -92,7 +88,7 @@
implementation
-uses {$IFNDEF PAS2C}typinfo, {$ENDIF}Math, uConsts, uVariables, SysUtils;
+uses typinfo, Math, uConsts, uVariables, SysUtils;
{$IFDEF DEBUGFILE}
var f: textfile;
@@ -135,11 +131,11 @@
end else b:= '';
end;
-{$IFNDEF PAS2C}
function EnumToStr(const en : TGearType) : shortstring; overload;
begin
EnumToStr:= GetEnumName(TypeInfo(TGearType), ord(en))
end;
+
function EnumToStr(const en : TVisualGearType) : shortstring; overload;
begin
EnumToStr:= GetEnumName(TypeInfo(TVisualGearType), ord(en))
@@ -164,7 +160,7 @@
begin
EnumToStr := GetEnumName(TypeInfo(TCapGroup), ord(en))
end;
-{$ENDIF}
+
function Min(a, b: LongInt): LongInt;
begin
@@ -407,7 +403,6 @@
CheckNoTeamOrHH:= (CurrentTeam = nil) or (CurrentHedgehog^.Gear = nil);
end;
-{$IFNDEF PAS2C}
procedure Write(var f: textfile; s: shortstring);
begin
system.write(f, s)
@@ -417,7 +412,7 @@
begin
system.writeln(f, s)
end;
-{$ENDIF}
+
// this function is just to determine whether we are running on a limited screen device
function isPhone: Boolean; inline;
--- a/tools/PascalBasics.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module PascalBasics where
-
-import Text.Parsec.Combinator
-import Text.Parsec.Char
-import Text.Parsec.Prim
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Data.Char
-
-builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
-
-pascalLanguageDef
- = emptyDef
- { commentStart = "(*"
- , commentEnd = "*)"
- , commentLine = "//"
- , nestedComments = False
- , identStart = letter <|> oneOf "_"
- , identLetter = alphaNum <|> oneOf "_"
- , reservedNames = [
- "begin", "end", "program", "unit", "interface"
- , "implementation", "and", "or", "xor", "shl"
- , "shr", "while", "do", "repeat", "until", "case", "of"
- , "type", "var", "const", "out", "array", "packed"
- , "procedure", "function", "with", "for", "to"
- , "downto", "div", "mod", "record", "set", "nil"
- , "cdecl", "external", "if", "then", "else"
- ] -- ++ builtin
- , reservedOpNames= []
- , caseSensitive = False
- }
-
-preprocessorSwitch :: Stream s m Char => ParsecT s u m String
-preprocessorSwitch = do
- try $ string "{$"
- s <- manyTill (noneOf "\n") $ char '}'
- return s
-
-caseInsensitiveString s = do
- mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
- return s
-
-pas = patch $ makeTokenParser pascalLanguageDef
- where
- patch tp = tp {stringLiteral = stringL}
-
-comment = choice [
- char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
- , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
- , (try $ string "//") >> manyTill anyChar (try newline)
- ]
-
-comments = do
- spaces
- skipMany $ do
- preprocessorSwitch <|> comment
- spaces
-
-stringL = do
- (char '\'')
- s <- (many $ noneOf "'")
- (char '\'')
- ss <- many $ do
- (char '\'')
- s' <- (many $ noneOf "'")
- (char '\'')
- return $ '\'' : s'
- comments
- return $ concat (s:ss)
--- a/tools/PascalParser.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,659 +0,0 @@
-module PascalParser where
-
-import Text.Parsec
-import Text.Parsec.Char
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Text.Parsec.Expr
-import Text.Parsec.Prim
-import Text.Parsec.Combinator
-import Text.Parsec.String
-import Control.Monad
-import Data.Maybe
-import Data.Char
-
-import PascalBasics
-import PascalUnitSyntaxTree
-
-knownTypes = ["shortstring", "ansistring", "char", "byte"]
-
-pascalUnit = do
- comments
- u <- choice [program, unit, systemUnit, redoUnit]
- comments
- return u
-
-iD = do
- i <- liftM (flip Identifier BTUnknown) (identifier pas)
- comments
- return i
-
-unit = do
- string "unit" >> comments
- name <- iD
- semi pas
- comments
- int <- interface
- impl <- implementation
- comments
- return $ Unit name int impl Nothing Nothing
-
-
-reference = buildExpressionParser table term <?> "reference"
- where
- term = comments >> choice [
- parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
- , try $ typeCast >>= postfixes
- , char '@' >> liftM Address reference >>= postfixes
- , liftM SimpleReference iD >>= postfixes
- ] <?> "simple reference"
-
- table = [
- ]
-
- postfixes r = many postfix >>= return . foldl (flip ($)) r
- postfix = choice [
- parens pas (option [] parameters) >>= return . FunCall
- , char '^' >> return Dereference
- , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
- , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
- ]
-
- typeCast = do
- t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
- e <- parens pas expression
- comments
- return $ TypeCast (Identifier t BTUnknown) e
-
-varsDecl1 = varsParser sepEndBy1
-varsDecl = varsParser sepEndBy
-varsParser m endsWithSemi = do
- vs <- m (aVarDecl endsWithSemi) (semi pas)
- return vs
-
-aVarDecl endsWithSemi = do
- isVar <- liftM (== Just "var") $
- if not endsWithSemi then
- optionMaybe $ choice [
- try $ string "var"
- , try $ string "const"
- , try $ string "out"
- ]
- else
- return Nothing
- comments
- ids <- do
- i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
- char ':'
- return i
- comments
- t <- typeDecl <?> "variable type declaration"
- comments
- init <- option Nothing $ do
- char '='
- comments
- e <- initExpression
- comments
- return (Just e)
- return $ VarDeclaration isVar False (ids, t) init
-
-
-constsDecl = do
- vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
- comments
- return vs
- where
- aConstDecl = do
- comments
- i <- iD
- t <- optionMaybe $ do
- char ':'
- comments
- t <- typeDecl
- comments
- return t
- char '='
- comments
- e <- initExpression
- comments
- return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
-
-typeDecl = choice [
- char '^' >> typeDecl >>= return . PointerTo
- , try (string "shortstring") >> return (String 255)
- , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
- , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
- , arrayDecl
- , recordDecl
- , setDecl
- , functionType
- , sequenceDecl >>= return . Sequence
- , try iD >>= return . SimpleType
- , rangeDecl >>= return . RangeType
- ] <?> "type declaration"
- where
- arrayDecl = do
- try $ do
- optional $ (try $ string "packed") >> comments
- string "array"
- comments
- r <- option [] $ do
- char '['
- r <- commaSep pas rangeDecl
- char ']'
- comments
- return r
- string "of"
- comments
- t <- typeDecl
- if null r then
- return $ ArrayDecl Nothing t
- else
- return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
- recordDecl = do
- try $ do
- optional $ (try $ string "packed") >> comments
- string "record"
- comments
- vs <- varsDecl True
- union <- optionMaybe $ do
- string "case"
- comments
- iD
- comments
- string "of"
- comments
- many unionCase
- string "end"
- return $ RecordType vs union
- setDecl = do
- try $ string "set" >> space
- comments
- string "of"
- comments
- liftM Set typeDecl
- unionCase = do
- try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
- char ':'
- comments
- u <- parens pas $ varsDecl True
- char ';'
- comments
- return u
- sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
- functionType = do
- fp <- try (string "function") <|> try (string "procedure")
- comments
- vs <- option [] $ parens pas $ varsDecl False
- comments
- ret <- if (fp == "function") then do
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- else
- return VoidType
- optional $ try $ char ';' >> comments >> string "cdecl"
- comments
- return $ FunctionType ret vs
-
-typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
- where
- aTypeDecl = do
- i <- try $ do
- i <- iD <?> "type declaration"
- comments
- char '='
- return i
- comments
- t <- typeDecl
- comments
- semi pas
- comments
- return $ TypeDeclaration i t
-
-rangeDecl = choice [
- try $ rangeft
- , iD >>= return . Range
- ] <?> "range declaration"
- where
- rangeft = do
- e1 <- initExpression
- string ".."
- e2 <- initExpression
- return $ RangeFromTo e1 e2
-
-typeVarDeclaration isImpl = (liftM concat . many . choice) [
- varSection,
- constSection,
- typeSection,
- funcDecl,
- operatorDecl
- ]
- where
- varSection = do
- try $ string "var"
- comments
- v <- varsDecl1 True <?> "variable declaration"
- comments
- return v
-
- constSection = do
- try $ string "const"
- comments
- c <- constsDecl <?> "const declaration"
- comments
- return c
-
- typeSection = do
- try $ string "type"
- comments
- t <- typesDecl <?> "type declaration"
- comments
- return t
-
- operatorDecl = do
- try $ string "operator"
- comments
- i <- manyTill anyChar space
- comments
- vs <- parens pas $ varsDecl False
- comments
- rid <- iD
- comments
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- char ';'
- comments
- forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
- inline <- liftM (any (== "inline;")) $ many functionDecorator
- b <- if isImpl && (not forward) then
- liftM Just functionBody
- else
- return Nothing
- return $ [OperatorDeclaration i rid inline ret vs b]
-
-
- funcDecl = do
- fp <- try (string "function") <|> try (string "procedure")
- comments
- i <- iD
- vs <- option [] $ parens pas $ varsDecl False
- comments
- ret <- if (fp == "function") then do
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- else
- return VoidType
- char ';'
- comments
- forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
- inline <- liftM (any (== "inline;")) $ many functionDecorator
- b <- if isImpl && (not forward) then
- liftM Just functionBody
- else
- return Nothing
- return $ [FunctionDeclaration i inline ret vs b]
-
- functionDecorator = do
- d <- choice [
- try $ string "inline;"
- , try $ caseInsensitiveString "cdecl;"
- , try $ string "overload;"
- , try $ string "export;"
- , try $ string "varargs;"
- , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
- ]
- comments
- return d
-
-
-program = do
- string "program"
- comments
- name <- iD
- (char ';')
- comments
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration True
- comments
- p <- phrase
- comments
- char '.'
- comments
- return $ Program name (Implementation u (TypesAndVars tv)) p
-
-interface = do
- string "interface"
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration False
- comments
- return $ Interface u (TypesAndVars tv)
-
-implementation = do
- string "implementation"
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration True
- string "end."
- comments
- return $ Implementation u (TypesAndVars tv)
-
-expression = do
- buildExpressionParser table term <?> "expression"
- where
- term = comments >> choice [
- builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
- , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
- , brackets pas (commaSep pas iD) >>= return . SetExpression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
- , float pas >>= return . FloatLiteral . show
- , try $ integer pas >>= return . NumberLiteral . show
- , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
- , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
- , stringLiteral pas >>= return . strOrChar
- , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
- , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
- , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h)
- --, char '-' >> expression >>= return . PrefixOp "-"
- , char '-' >> reference >>= return . PrefixOp "-" . Reference
- , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
- , try $ string "nil" >> return Null
- , reference >>= return . Reference
- ] <?> "simple expression"
-
- table = [
- [ Prefix (try (string "not") >> return (PrefixOp "not"))
- , Prefix (try (char '-') >> return (PrefixOp "-"))]
- ,
- [ Infix (char '*' >> return (BinOp "*")) AssocLeft
- , Infix (char '/' >> return (BinOp "/")) AssocLeft
- , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
- , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
- , Infix (try (string "in") >> return (BinOp "in")) AssocNone
- , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
- , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
- , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
- ]
- , [ Infix (char '+' >> return (BinOp "+")) AssocLeft
- , Infix (char '-' >> return (BinOp "-")) AssocLeft
- , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
- ]
- , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
- , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
- , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
- , Infix (char '<' >> return (BinOp "<")) AssocNone
- , Infix (char '>' >> return (BinOp ">")) AssocNone
- ]
- {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
- ]
- , [
- Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
- ]-}
- , [
- Infix (char '=' >> return (BinOp "=")) AssocNone
- ]
- ]
- strOrChar [a] = CharCode . show . ord $ a
- strOrChar a = StringLiteral a
-
-phrasesBlock = do
- try $ string "begin"
- comments
- p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
- comments
- return $ Phrases p
-
-phrase = do
- o <- choice [
- phrasesBlock
- , ifBlock
- , whileCycle
- , repeatCycle
- , switchCase
- , withBlock
- , forCycle
- , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
- , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
- , procCall
- , char ';' >> comments >> return NOP
- ]
- optional $ char ';'
- comments
- return o
-
-ifBlock = do
- try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
- comments
- e <- expression
- comments
- string "then"
- comments
- o1 <- phrase
- comments
- o2 <- optionMaybe $ do
- try $ string "else" >> space
- comments
- o <- option NOP phrase
- comments
- return o
- return $ IfThenElse e o1 o2
-
-whileCycle = do
- try $ string "while"
- comments
- e <- expression
- comments
- string "do"
- comments
- o <- phrase
- return $ WhileCycle e o
-
-withBlock = do
- try $ string "with" >> space
- comments
- rs <- (commaSep1 pas) reference
- comments
- string "do"
- comments
- o <- phrase
- return $ foldr WithBlock o rs
-
-repeatCycle = do
- try $ string "repeat" >> space
- comments
- o <- many phrase
- string "until"
- comments
- e <- expression
- comments
- return $ RepeatCycle e o
-
-forCycle = do
- try $ string "for" >> space
- comments
- i <- iD
- comments
- string ":="
- comments
- e1 <- expression
- comments
- up <- liftM (== Just "to") $
- optionMaybe $ choice [
- try $ string "to"
- , try $ string "downto"
- ]
- --choice [string "to", string "downto"]
- comments
- e2 <- expression
- comments
- string "do"
- comments
- p <- phrase
- comments
- return $ ForCycle i e1 e2 p up
-
-switchCase = do
- try $ string "case"
- comments
- e <- expression
- comments
- string "of"
- comments
- cs <- many1 aCase
- o2 <- optionMaybe $ do
- try $ string "else" >> notFollowedBy alphaNum
- comments
- o <- many phrase
- comments
- return o
- string "end"
- comments
- return $ SwitchCase e cs o2
- where
- aCase = do
- e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
- comments
- char ':'
- comments
- p <- phrase
- comments
- return (e, p)
-
-procCall = do
- r <- reference
- p <- option [] $ (parens pas) parameters
- return $ ProcCall r p
-
-parameters = (commaSep pas) expression <?> "parameters"
-
-functionBody = do
- tv <- typeVarDeclaration True
- comments
- p <- phrasesBlock
- char ';'
- comments
- return (TypesAndVars tv, p)
-
-uses = liftM Uses (option [] u)
- where
- u = do
- string "uses"
- comments
- u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
- char ';'
- comments
- return u
-
-initExpression = buildExpressionParser table term <?> "initialization expression"
- where
- term = comments >> choice [
- liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
- , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
- , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia)
- , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
- , parens pas initExpression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
- , try $ float pas >>= return . InitFloat . show
- , try $ integer pas >>= return . InitNumber . show
- , stringLiteral pas >>= return . InitString
- , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
- , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
- , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
- , try $ string "nil" >> return InitNull
- , itypeCast
- , iD >>= return . InitReference
- ]
-
- recField = do
- i <- iD
- spaces
- char ':'
- spaces
- e <- initExpression
- spaces
- return (i ,e)
-
- table = [
- [
- Prefix (char '-' >> return (InitPrefixOp "-"))
- ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
- ]
- , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft
- , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
- , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
- , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
- , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
- , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
- ]
- , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft
- , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
- , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
- ]
- , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
- , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
- , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
- , Infix (char '<' >> return (InitBinOp "<")) AssocNone
- , Infix (char '>' >> return (InitBinOp ">")) AssocNone
- , Infix (char '=' >> return (InitBinOp "=")) AssocNone
- ]
- {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
- , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
- ]
- , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
- ]--}
- --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
- ]
-
- itypeCast = do
- t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
- i <- parens pas initExpression
- comments
- return $ InitTypeCast (Identifier t BTUnknown) i
-
-builtInFunction e = do
- name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
- spaces
- exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
- spaces
- return (name, exprs)
-
-systemUnit = do
- string "system;"
- comments
- string "type"
- comments
- t <- typesDecl
- string "var"
- v <- varsDecl True
- return $ System (t ++ v)
-
-redoUnit = do
- string "redo;"
- comments
- string "type"
- comments
- t <- typesDecl
- string "var"
- v <- varsDecl True
- return $ Redo (t ++ v)
-
--- a/tools/PascalPreprocessor.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,134 +0,0 @@
-module PascalPreprocessor where
-
-import Text.Parsec
-import Control.Monad.IO.Class
-import Control.Monad
-import System.IO
-import qualified Data.Map as Map
-import Data.Char
-
-
--- comments are removed
-comment = choice [
- char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
- , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
- , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
- ]
-
-initDefines = Map.fromList [
- ("FPC", "")
- , ("PAS2C", "")
- , ("ENDIAN_LITTLE", "")
- ]
-
-preprocess :: String -> IO String
-preprocess fn = do
- r <- runParserT (preprocessFile fn) (initDefines, [True]) "" ""
- case r of
- (Left a) -> do
- hPutStrLn stderr (show a)
- return ""
- (Right a) -> return a
-
- where
- preprocessFile fn = do
- f <- liftIO (readFile fn)
- setInput f
- preprocessor
-
- preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String
-
- preprocessor = chainr codeBlock (return (++)) ""
-
- codeBlock = do
- s <- choice [
- switch
- , comment
- , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
- , identifier >>= replace
- , noneOf "{" >>= \a -> return [a]
- ]
- (_, ok) <- getState
- return $ if and ok then s else ""
-
- --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)
- identifier = do
- c <- letter <|> oneOf "_"
- s <- many (alphaNum <|> oneOf "_")
- return $ c:s
-
- switch = do
- try $ string "{$"
- s <- choice [
- include
- , ifdef
- , if'
- , elseSwitch
- , endIf
- , define
- , unknown
- ]
- return s
-
- include = do
- try $ string "INCLUDE"
- spaces
- (char '"')
- fn <- many1 $ noneOf "\"\n"
- char '"'
- spaces
- char '}'
- f <- liftIO (readFile fn `catch` error ("File not found: " ++ fn))
- c <- getInput
- setInput $ f ++ c
- return ""
-
- ifdef = do
- s <- try (string "IFDEF") <|> try (string "IFNDEF")
- let f = if s == "IFNDEF" then not else id
-
- spaces
- d <- identifier
- spaces
- char '}'
-
- updateState $ \(m, b) ->
- (m, (f $ d `Map.member` m) : b)
-
- return ""
-
- if' = do
- s <- try (string "IF" >> notFollowedBy alphaNum)
-
- manyTill anyChar (char '}')
- --char '}'
-
- updateState $ \(m, b) ->
- (m, False : b)
-
- return ""
-
- elseSwitch = do
- try $ string "ELSE}"
- updateState $ \(m, b:bs) -> (m, (not b):bs)
- return ""
- endIf = do
- try $ string "ENDIF}"
- updateState $ \(m, b:bs) -> (m, bs)
- return ""
- define = do
- try $ string "DEFINE"
- spaces
- i <- identifier
- d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
- char '}'
- updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
- return ""
- replace s = do
- (m, _) <- getState
- return $ Map.findWithDefault s s m
-
- unknown = do
- fn <- many1 $ noneOf "}\n"
- char '}'
- return $ "{$" ++ fn ++ "}"
--- a/tools/PascalUnitSyntaxTree.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,119 +0,0 @@
-module PascalUnitSyntaxTree where
-
-import Data.Maybe
-import Data.Char
-
-data PascalUnit =
- Program Identifier Implementation Phrase
- | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
- | System [TypeVarDeclaration]
- | Redo [TypeVarDeclaration]
- deriving Show
-data Interface = Interface Uses TypesAndVars
- deriving Show
-data Implementation = Implementation Uses TypesAndVars
- deriving Show
-data Identifier = Identifier String BaseType
- deriving Show
-data TypesAndVars = TypesAndVars [TypeVarDeclaration]
- deriving Show
-data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
- | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
- | FunctionDeclaration Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
- | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
- deriving Show
-data TypeDecl = SimpleType Identifier
- | RangeType Range
- | Sequence [Identifier]
- | ArrayDecl (Maybe Range) TypeDecl
- | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
- | PointerTo TypeDecl
- | String Integer
- | Set TypeDecl
- | FunctionType TypeDecl [TypeVarDeclaration]
- | DeriveType InitExpression
- | VoidType
- | VarParamType TypeDecl -- this is a hack
- deriving Show
-data Range = Range Identifier
- | RangeFromTo InitExpression InitExpression
- | RangeInfinite
- deriving Show
-data Initialize = Initialize String
- deriving Show
-data Finalize = Finalize String
- deriving Show
-data Uses = Uses [Identifier]
- deriving Show
-data Phrase = ProcCall Reference [Expression]
- | IfThenElse Expression Phrase (Maybe Phrase)
- | WhileCycle Expression Phrase
- | RepeatCycle Expression [Phrase]
- | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
- | WithBlock Reference Phrase
- | Phrases [Phrase]
- | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
- | Assignment Reference Expression
- | BuiltInFunctionCall [Expression] Reference
- | NOP
- deriving Show
-data Expression = Expression String
- | BuiltInFunCall [Expression] Reference
- | PrefixOp String Expression
- | PostfixOp String Expression
- | BinOp String Expression Expression
- | StringLiteral String
- | PCharLiteral String
- | CharCode String
- | HexCharCode String
- | NumberLiteral String
- | FloatLiteral String
- | HexNumber String
- | Reference Reference
- | SetExpression [Identifier]
- | Null
- deriving Show
-data Reference = ArrayElement [Expression] Reference
- | FunCall [Expression] Reference
- | TypeCast Identifier Expression
- | SimpleReference Identifier
- | Dereference Reference
- | RecordField Reference Reference
- | Address Reference
- | RefExpression Expression
- deriving Show
-data InitExpression = InitBinOp String InitExpression InitExpression
- | InitPrefixOp String InitExpression
- | InitReference Identifier
- | InitArray [InitExpression]
- | InitRecord [(Identifier, InitExpression)]
- | InitFloat String
- | InitNumber String
- | InitHexNumber String
- | InitString String
- | InitChar String
- | BuiltInFunction String [InitExpression]
- | InitSet [InitExpression]
- | InitAddress InitExpression
- | InitNull
- | InitRange Range
- | InitTypeCast Identifier InitExpression
- deriving Show
-
-data BaseType = BTUnknown
- | BTChar
- | BTString
- | BTInt
- | BTBool
- | BTFloat
- | BTRecord String [(String, BaseType)]
- | BTArray Range BaseType BaseType
- | BTFunction Bool Int BaseType
- | BTPointerTo BaseType
- | BTUnresolved String
- | BTSet BaseType
- | BTEnum [String]
- | BTVoid
- | BTUnit
- | BTVarParam BaseType
- deriving Show
--- a/tools/pas2c.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1086 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Pas2C where
-
-import Text.PrettyPrint.HughesPJ
-import Data.Maybe
-import Data.Char
-import Text.Parsec.Prim hiding (State)
-import Control.Monad.State
-import System.IO
-import System.Directory
-import Control.Monad.IO.Class
-import PascalPreprocessor
-import Control.Exception
-import System.IO.Error
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.List (find)
-import Numeric
-
-import PascalParser(pascalUnit)
-import PascalUnitSyntaxTree
-
-
-data InsertOption =
- IOInsert
- | IOInsertWithType Doc
- | IOLookup
- | IOLookupLast
- | IOLookupFunction Int
- | IODeferred
-
-data Record = Record
- {
- lcaseId :: String,
- baseType :: BaseType,
- typeDecl :: Doc
- }
- deriving Show
-type Records = Map.Map String [Record]
-data RenderState = RenderState
- {
- currentScope :: Records,
- lastIdentifier :: String,
- lastType :: BaseType,
- lastIdTypeDecl :: Doc,
- stringConsts :: [(String, String)],
- uniqCounter :: Int,
- toMangle :: Set.Set String,
- currentUnit :: String,
- currentFunctionResult :: String,
- namespaces :: Map.Map String Records
- }
-
-rec2Records = map (\(a, b) -> Record a b empty)
-
-emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""
-
-getUniq :: State RenderState Int
-getUniq = do
- i <- gets uniqCounter
- modify(\s -> s{uniqCounter = uniqCounter s + 1})
- return i
-
-addStringConst :: String -> State RenderState Doc
-addStringConst str = do
- strs <- gets stringConsts
- let a = find ((==) str . snd) strs
- if isJust a then
- do
- modify (\s -> s{lastType = BTString})
- return . text . fst . fromJust $ a
- else
- do
- i <- getUniq
- let sn = "__str" ++ show i
- modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
- return $ text sn
-
-escapeStr :: String -> String
-escapeStr = foldr escapeChar []
-
-escapeChar :: Char -> ShowS
-escapeChar '"' s = "\\\"" ++ s
-escapeChar '\\' s = "\\\\" ++ s
-escapeChar a s = a : s
-
-strInit :: String -> Doc
-strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
-
-renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
- $ gets stringConsts
-
-docToLower :: Doc -> Doc
-docToLower = text . map toLower . render
-
-pas2C :: String -> IO ()
-pas2C fn = do
- setCurrentDirectory "../hedgewars/"
- s <- flip execStateT initState $ f fn
- renderCFiles s
- where
- printLn = liftIO . hPutStrLn stdout
- print = liftIO . hPutStr stdout
- initState = Map.empty
- f :: String -> StateT (Map.Map String PascalUnit) IO ()
- f fileName = do
- processed <- gets $ Map.member fileName
- unless processed $ do
- print ("Preprocessing '" ++ fileName ++ ".pas'... ")
- fc' <- liftIO
- $ tryJust (guard . isDoesNotExistError)
- $ preprocess (fileName ++ ".pas")
- case fc' of
- (Left a) -> do
- modify (Map.insert fileName (System []))
- printLn "doesn't exist"
- (Right fc) -> do
- print "ok, parsing... "
- let ptree = parse pascalUnit fileName fc
- case ptree of
- (Left a) -> do
- liftIO $ writeFile "preprocess.out" fc
- printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
- fail "stop"
- (Right a) -> do
- printLn "ok"
- modify (Map.insert fileName a)
- mapM_ f (usesFiles a)
-
-
-renderCFiles :: Map.Map String PascalUnit -> IO ()
-renderCFiles units = do
- let u = Map.toList units
- let nss = Map.map (toNamespace nss) units
- --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
- --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
- mapM_ (toCFiles nss) u
- where
- toNamespace :: Map.Map String Records -> PascalUnit -> Records
- toNamespace nss (System tvs) =
- currentScope $ execState f (emptyState nss)
- where
- f = do
- checkDuplicateFunDecls tvs
- mapM_ (tvar2C True False True False) tvs
- toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
- currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
- where
- f = do
- checkDuplicateFunDecls tvs
- mapM_ (tvar2C True False True False) tvs
- toNamespace _ (Program {}) = Map.empty
- toNamespace nss (Unit (Identifier i _) interface _ _ _) =
- currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
-
-
-withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
-withState' f sf = do
- st <- liftM f get
- let (a, s) = runState sf st
- modify(\st -> st{
- lastType = lastType s
- , uniqCounter = uniqCounter s
- , stringConsts = stringConsts s
- })
- return a
-
-withLastIdNamespace f = do
- li <- gets lastIdentifier
- nss <- gets namespaces
- withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
-
-withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
-withRecordNamespace _ [] = error "withRecordNamespace: empty record"
-withRecordNamespace prefix recs = withState' f
- where
- f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
- records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
- un [a] b = a : b
-
-toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO ()
-toCFiles _ (_, System _) = return ()
-toCFiles _ (_, Redo _) = return ()
-toCFiles ns p@(fn, pu) = do
- hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
- toCFiles' p
- where
- toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
- toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
- let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
- (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
- writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
- writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
- initialState = emptyState ns
-
- render2C :: RenderState -> State RenderState Doc -> String
- render2C a = render . ($+$ empty) . flip evalState a
-
-
-usesFiles :: PascalUnit -> [String]
-usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
-usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
-usesFiles (System {}) = []
-usesFiles (Redo {}) = []
-
-pascal2C :: PascalUnit -> State RenderState Doc
-pascal2C (Unit _ interface implementation init fin) =
- liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
-
-pascal2C (Program _ implementation mainFunction) = do
- impl <- implementation2C implementation
- [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
- return $ impl $+$ main
-
-
--- the second bool indicates whether do normal interface translation or generate variable declarations
--- that will be inserted into implementation files
-interface2C :: Interface -> Bool -> State RenderState Doc
-interface2C (Interface uses tvars) True = do
- u <- uses2C uses
- tv <- typesAndVars2C True True True tvars
- r <- renderStringConsts
- return (u $+$ r $+$ tv)
-interface2C (Interface uses tvars) False = do
- u <- uses2C uses
- tv <- typesAndVars2C True False False tvars
- r <- renderStringConsts
- return tv
-
-implementation2C :: Implementation -> State RenderState Doc
-implementation2C (Implementation uses tvars) = do
- u <- uses2C uses
- tv <- typesAndVars2C True False True tvars
- r <- renderStringConsts
- return (u $+$ r $+$ tv)
-
-checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
-checkDuplicateFunDecls tvs =
- modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
- where
- initMap = Map.empty
- --initMap = Map.fromList [("reset", 2)]
- ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
- ins _ m = m
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
-
-typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
-typesAndVars2C b externVar includeType(TypesAndVars ts) = do
- checkDuplicateFunDecls ts
- liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
-
-setBaseType :: BaseType -> Identifier -> Identifier
-setBaseType bt (Identifier i _) = Identifier i bt
-
-uses2C :: Uses -> State RenderState Doc
-uses2C uses@(Uses unitIds) = do
-
- mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
- mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
- mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
- return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
- where
- injectNamespace (Identifier i _) = do
- getNS <- gets (flip Map.lookup . namespaces)
- modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
-
-uses2List :: Uses -> [String]
-uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
-
-
-setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
-
-id2C :: InsertOption -> Identifier -> State RenderState Doc
-id2C IOInsert i = id2C (IOInsertWithType empty) i
-id2C (IOInsertWithType d) (Identifier i t) = do
- ns <- gets currentScope
- tom <- gets (Set.member n . toMangle)
- cu <- gets currentUnit
- let (i', t') = case (t, tom) of
- (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
- (BTFunction _ _ _, _) -> (cu ++ i, t)
- (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
- _ -> (i, t)
- modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
- return $ text i'
- where
- n = map toLower i
-
-id2C IOLookup i = id2CLookup head i
-id2C IOLookupLast i = id2CLookup last i
-id2C (IOLookupFunction params) (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- lt <- gets lastType
- if isNothing v then
- error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
- else
- let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
- modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
- where
- checkParam (Record _ (BTFunction _ p _) _) = p == params
- checkParam _ = False
-id2C IODeferred (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- if (isNothing v) then
- modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
- else
- let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- lt <- gets lastType
- if isNothing v then
- error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
- else
- let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-
-id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped = id2CTyped2 Nothing
-
-id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped2 md t (Identifier i _) = do
- tb <- resolveType t
- case (t, tb) of
- (_, BTUnknown) -> do
- error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
- (SimpleType {}, BTRecord _ r) -> do
- ts <- type2C t
- id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
- (_, BTRecord _ r) -> do
- ts <- type2C t
- id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
- _ -> case md of
- Nothing -> id2C IOInsert (Identifier i tb)
- Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
-
-
-resolveType :: TypeDecl -> State RenderState BaseType
-resolveType st@(SimpleType (Identifier i _)) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- if isJust v then return . baseType . head $ fromJust v else return $ f i'
- where
- f "integer" = BTInt
- f "pointer" = BTPointerTo BTVoid
- f "boolean" = BTBool
- f "float" = BTFloat
- f "char" = BTChar
- f "string" = BTString
- f _ = error $ "Unknown system type: " ++ show st
-resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
-resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
-resolveType (RecordType tv mtvs) = do
- tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
- return . BTRecord "" . concat $ tvs
- where
- f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
- f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
-resolveType (ArrayDecl (Just i) t) = do
- t' <- resolveType t
- return $ BTArray i BTInt t'
-resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
-resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
-resolveType (DeriveType (InitHexNumber _)) = return BTInt
-resolveType (DeriveType (InitNumber _)) = return BTInt
-resolveType (DeriveType (InitFloat _)) = return BTFloat
-resolveType (DeriveType (InitString _)) = return BTString
-resolveType (DeriveType (InitBinOp {})) = return BTInt
-resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
-resolveType (DeriveType (BuiltInFunction{})) = return BTInt
-resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
-resolveType (DeriveType _) = return BTUnknown
-resolveType (String _) = return BTString
-resolveType VoidType = return BTVoid
-resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
-resolveType (RangeType _) = return $ BTVoid
-resolveType (Set t) = liftM BTSet $ resolveType t
-resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
-
-
-resolve :: String -> BaseType -> State RenderState BaseType
-resolve s (BTUnresolved t) = do
- v <- gets $ Map.lookup t . currentScope
- if isJust v then
- resolve s . baseType . head . fromJust $ v
- else
- error $ "Unknown type " ++ show t ++ "\n" ++ s
-resolve _ t = return t
-
-fromPointer :: String -> BaseType -> State RenderState BaseType
-fromPointer s (BTPointerTo t) = resolve s t
-fromPointer s t = do
- error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
-
-
-functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
-
-numberOfDeclarations :: [TypeVarDeclaration] -> Int
-numberOfDeclarations = sum . map cnt
- where
- cnt (VarDeclaration _ _ (ids, _) _) = length ids
- cnt _ = 1
-
-hasPassByReference :: [TypeVarDeclaration] -> Bool
-hasPassByReference = or . map isVar
- where
- isVar (VarDeclaration v _ (_, _) _) = v
- isVar _ = error $ "hasPassByReference called not on function parameters"
-
-toIsVarList :: [TypeVarDeclaration] -> [Bool]
-toIsVarList = concatMap isVar
- where
- isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
- isVar _ = error $ "toIsVarList called not on function parameters"
-
-
-funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
-funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
- where
- abc = hcat . punctuate comma . map (char . fst) $ ps
- cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
- ps = zip ['a'..] (toIsVarList params)
-
-fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
- t <- type2C returnType
- t'<- gets lastType
- p <- withState' id $ functionParams2C params
- n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
- let decor = if inline then text "inline" else empty
- if hasVars then
- return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
- else
- return [decor <+> t empty <+> text n <> parens p]
- where
- hasVars = hasPassByReference params
-
-
-fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
- let res = docToLower $ text rv <> text "_result"
- t <- type2C returnType
- t'<- gets lastType
-
- notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
-
- n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
-
- let isVoid = case returnType of
- VoidType -> True
- _ -> False
-
- (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
- , currentFunctionResult = if isVoid then [] else render res}) $ do
- p <- functionParams2C params
- ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
- return (p, ph)
-
- let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
- let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
- let decor = if inline then text "inline" else empty
- return [
- define
- $+$
- --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
- decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
- $+$
- text "{"
- $+$
- nest 4 phrasesBlock
- $+$
- text "}"]
- where
- phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
- phrase2C' p = phrase2C p
- un [a] b = a : b
- hasVars = hasPassByReference params
-
-fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
-fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
--- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
-tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
-tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do
- t <- fun2C b name f
- if includeType then return t else return []
-tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
- i <- id2CTyped t i'
- tp <- type2C t
- return $ if includeType then [text "typedef" <+> tp i] else []
-
-tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
- t' <- liftM ((empty <+>) . ) $ type2C t
- liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
-
-tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
- t' <- liftM (((if isConst then text "static const" else if externVar
- then text "extern"
- else empty)
- <+>) . ) $ type2C t
- ie <- initExpr mInitExpr
- lt <- gets lastType
- case (isConst, lt, ids, mInitExpr) of
- (True, BTInt, [i], Just _) -> do
- i' <- id2CTyped t i
- return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
- (True, BTFloat, [i], Just e) -> do
- i' <- id2CTyped t i
- ie <- initExpr2C e
- return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
- (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
- (_, BTArray r _ _, [i], _) -> do
- i' <- id2CTyped t i
- ie' <- return $ case (r, mInitExpr, ignoreInit) of
- (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
- (_, _, _) -> ie
- result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
- case (r, ignoreInit) of
- (RangeInfinite, False) ->
- -- if the array is dynamic, add dimension info to it
- return $ [dimDecl] ++ result
- where
- arrayDimStr = show $ arrayDimension t
- arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
- dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp
-
- (_, _) -> return result
-
- _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
- where
- initExpr Nothing = return $ empty
- initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
- varDeclDecision True True varStr expStr = varStr <+> expStr
- varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
- varDeclDecision False False varStr expStr = varStr <+> expStr
- varDeclDecision True False varStr expStr = empty
- arrayDimension a = case a of
- ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
- ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
- _ -> 0
-
-tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
- r <- op2CTyped op (extractTypes params)
- fun2C f i (FunctionDeclaration r inline ret params body)
-
-
-op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
-op2CTyped op t = do
- t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
- bt <- gets lastType
- return $ Identifier (t' ++ "_op_" ++ opStr) bt
- where
- opStr = case op of
- "+" -> "add"
- "-" -> "sub"
- "*" -> "mul"
- "/" -> "div"
- "/(float)" -> "div"
- "=" -> "eq"
- "<" -> "lt"
- ">" -> "gt"
- "<>" -> "neq"
- _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
-
-extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
-extractTypes = concatMap f
- where
- f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
- f a = error $ "extractTypes: can't extract from " ++ show a
-
-initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
-initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
-initExpr2C a = initExpr2C' a
-initExpr2C' InitNull = return $ text "NULL"
-initExpr2C' (InitAddress expr) = do
- ie <- initExpr2C' expr
- lt <- gets lastType
- case lt of
- BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"
- _ -> return $ text "&" <> ie
-initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
-initExpr2C' (InitBinOp op expr1 expr2) = do
- e1 <- initExpr2C' expr1
- e2 <- initExpr2C' expr2
- return $ parens $ e1 <+> text (op2C op) <+> e2
-initExpr2C' (InitNumber s) = return $ text s
-initExpr2C' (InitFloat s) = return $ text s
-initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-initExpr2C' (InitString [a]) = return . quotes $ text [a]
-initExpr2C' (InitString s) = return $ strInit s
-initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
-initExpr2C' (InitReference i) = id2C IOLookup i
-initExpr2C' (InitRecord fields) = do
- (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
- return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
-initExpr2C' (InitArray [value]) = initExpr2C value
-initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
- id2C IOLookup i
- t <- gets lastType
- case t of
- BTEnum s -> return . int $ length s
- BTInt -> case i' of
- "byte" -> return $ int 256
- _ -> error $ "InitRange identifier: " ++ i'
- _ -> error $ "InitRange: " ++ show r
-initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
-initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
-initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
-initExpr2C' (InitSet []) = return $ text "0"
-initExpr2C' (InitSet a) = return $ text "<<set>>"
-initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
- case e of
- (Identifier "LongInt" _) -> int (-2^31)
- (Identifier "SmallInt" _) -> int (-2^15)
- _ -> error $ "BuiltInFunction 'low': " ++ show e
-initExpr2C' (BuiltInFunction "high" [e]) = do
- initExpr2C e
- t <- gets lastType
- case t of
- (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
- a -> error $ "BuiltInFunction 'high': " ++ show a
-initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
-initExpr2C' b@(BuiltInFunction _ _) = error $ show b
-initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
-
-
-range2C :: InitExpression -> State RenderState [Doc]
-range2C (InitString [a]) = return [quotes $ text [a]]
-range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
-range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
-range2C a = liftM (flip (:) []) $ initExpr2C a
-
-baseType2C :: String -> BaseType -> Doc
-baseType2C _ BTFloat = text "float"
-baseType2C _ BTBool = text "bool"
-baseType2C _ BTString = text "string255"
-baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
-
-type2C :: TypeDecl -> State RenderState (Doc -> Doc)
-type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
-type2C t = do
- r <- type2C' t
- rt <- resolveType t
- modify (\st -> st{lastType = rt})
- return r
- where
- type2C' VoidType = return (text "void" <+>)
- type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
- type2C' (PointerTo (SimpleType i)) = do
- i' <- id2C IODeferred i
- lt <- gets lastType
- case lt of
- BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
- BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
- _ -> return $ \a -> i' <+> text "*" <+> a
- type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
- type2C' (RecordType tvs union) = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
- u <- unions
- return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
- where
- f s = s{currentUnit = ""}
- unions = case union of
- Nothing -> return empty
- Just a -> do
- structs <- mapM struct2C a
- return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
- struct2C tvs = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
- return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
- type2C' (RangeType r) = return (text "int" <+>)
- type2C' (Sequence ids) = do
- is <- mapM (id2C IOInsert . setBaseType bt) ids
- return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
- where
- bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
- type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
- type2C' (ArrayDecl (Just r) t) = do
- t' <- type2C t
- lt <- gets lastType
- ft <- case lt of
- -- BTFunction {} -> type2C (PointerTo t)
- _ -> return t'
- r' <- initExpr2C (InitRange r)
- return $ \i -> ft i <> brackets r'
- type2C' (Set t) = return (text "<<set>>" <+>)
- type2C' (FunctionType returnType params) = do
- t <- type2C returnType
- p <- withState' id $ functionParams2C params
- return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
- type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
- type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
- type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
- type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
- type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
- type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
- type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
- type2C' (DeriveType r@(InitReference {})) = do
- initExpr2C r
- t <- gets lastType
- return (baseType2C (show r) t <+>)
- type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
-
-phrase2C :: Phrase -> State RenderState Doc
-phrase2C (Phrases p) = do
- ps <- mapM phrase2C p
- return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
-phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
-phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
-phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
- r <- ref2C ref
- ps <- mapM expr2C params
- return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
-phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
- e <- expr2C expr
- p1 <- (phrase2C . wrapPhrase) phrase1
- el <- elsePart
- return $
- text "if" <> parens e $+$ p1 $+$ el
- where
- elsePart | isNothing mphrase2 = return $ empty
- | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
-phrase2C (Assignment ref expr) = do
- r <- ref2C ref
- t <- gets lastType
- case (t, expr) of
- (BTFunction {}, (Reference r')) -> do
- e <- ref2C r'
- return $ r <+> text "=" <+> e <> semi
- (BTString, _) -> do
- e <- expr2C expr
- lt <- gets lastType
- case lt of
- -- assume pointer to char for simplicity
- BTPointerTo _ -> do
- e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
- return $ r <+> text "=" <+> e <> semi
- BTString -> do
- e <- expr2C expr
- return $ r <+> text "=" <+> e <> semi
- _ -> error $ "Assignment to string from " ++ show lt
- (BTArray _ _ _, _) -> do
- case expr of
- Reference er -> do
- exprRef <- ref2C er
- exprT <- gets lastType
- case exprT of
- BTArray RangeInfinite _ _ ->
- return $ text "FIXME: assign a dynamic array to an array"
- BTArray _ _ _ -> phrase2C $
- ProcCall (FunCall
- [
- Reference $ ref
- , Reference $ RefExpression expr
- , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
- ]
- (SimpleReference (Identifier "memcpy" BTUnknown))
- ) []
- _ -> return $ text "FIXME: assign a non-specific value to an array"
-
- _ -> return $ text "FIXME: dynamic array assignment 2"
- _ -> do
- e <- expr2C expr
- return $ r <+> text "=" <+> e <> semi
-phrase2C (WhileCycle expr phrase) = do
- e <- expr2C expr
- p <- phrase2C $ wrapPhrase phrase
- return $ text "while" <> parens e $$ p
-phrase2C (SwitchCase expr cases mphrase) = do
- e <- expr2C expr
- cs <- mapM case2C cases
- d <- dflt
- return $
- text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
- where
- case2C :: ([InitExpression], Phrase) -> State RenderState Doc
- case2C (e, p) = do
- ies <- mapM range2C e
- ph <- phrase2C p
- return $
- vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
- dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
- | otherwise = do
- ph <- mapM phrase2C $ fromJust mphrase
- return [text "default:" <+> nest 4 (vcat ph)]
-
-phrase2C wb@(WithBlock ref p) = do
- r <- ref2C ref
- t <- gets lastType
- case t of
- (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
- a -> do
- error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
-phrase2C (ForCycle i' e1' e2' p up) = do
- i <- id2C IOLookup i'
- iType <- gets lastIdTypeDecl
- e1 <- expr2C e1'
- e2 <- expr2C e2'
- let inc = if up then "inc" else "dec"
- let add = if up then "+ 1" else "- 1"
- let iEnd = i <> text "__end__"
- ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
- return . braces $
- i <+> text "=" <+> e1 <> semi
- $$
- iType <+> iEnd <+> text "=" <+> e2 <> semi
- $$
- text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
- text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
- where
- appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
-phrase2C (RepeatCycle e' p') = do
- e <- expr2C e'
- p <- phrase2C (Phrases p')
- return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
-phrase2C NOP = return $ text ";"
-
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
- f <- gets currentFunctionResult
- if null f then
- return $ text "return" <> semi
- else
- return $ text "return" <+> text f <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C a = error $ "phrase2C: " ++ show a
-
-wrapPhrase p@(Phrases _) = p
-wrapPhrase p = Phrases [p]
-
-expr2C :: Expression -> State RenderState Doc
-expr2C (Expression s) = return $ text s
-expr2C b@(BinOp op expr1 expr2) = do
- e1 <- expr2C expr1
- t1 <- gets lastType
- e2 <- expr2C expr2
- t2 <- gets lastType
- case (op2C op, t1, t2) of
- ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))
- ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))
- ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))
- ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))
- ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))
- ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))
- ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))
- ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
- ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
- (_, BTRecord t1 _, BTRecord t2 _) -> do
- i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
- ref2C $ FunCall [expr1, expr2] (SimpleReference i)
- (_, BTRecord t1 _, BTInt) -> do
- -- aw, "LongInt" here is hwengine-specific hack
- i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
- ref2C $ FunCall [expr1, expr2] (SimpleReference i)
- ("in", _, _) ->
- case expr2 of
- SetExpression set -> do
- ids <- mapM (id2C IOLookup) set
- modify(\s -> s{lastType = BTBool})
- return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
- _ -> error "'in' against not set expression"
- (o, _, _) | o `elem` boolOps -> do
- modify(\s -> s{lastType = BTBool})
- return $ parens e1 <+> text o <+> parens e2
- | otherwise -> do
- o' <- return $ case o of
- "/(float)" -> text "/(float)" -- pascal returns real value
- _ -> text o
- e1' <- return $ case (o, t1, t2) of
- ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
- _ -> parens e1
- e2' <- return $ case (o, t1, t2) of
- ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
- _ -> parens e2
- return $ e1' <+> o' <+> e2'
- where
- boolOps = ["==", "!=", "<", ">", "<=", ">="]
-expr2C (NumberLiteral s) = do
- modify(\s -> s{lastType = BTInt})
- return $ text s
-expr2C (FloatLiteral s) = return $ text s
-expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-{-expr2C (StringLiteral [a]) = do
- modify(\s -> s{lastType = BTChar})
- return . quotes . text $ escape a
- where
- escape '\'' = "\\\'"
- escape a = [a]-}
-expr2C (StringLiteral s) = addStringConst s
-expr2C (PCharLiteral s) = return . doubleQuotes $ text s
-expr2C (Reference ref) = ref2CF ref
-expr2C (PrefixOp op expr) = do
- e <- expr2C expr
- lt <- gets lastType
- case lt of
- BTRecord t _ -> do
- i <- op2CTyped op [SimpleType (Identifier t undefined)]
- ref2C $ FunCall [expr] (SimpleReference i)
- BTBool -> do
- o <- return $ case op of
- "not" -> text "!"
- _ -> text (op2C op)
- return $ o <> parens e
- _ -> return $ text (op2C op) <> parens e
-expr2C Null = return $ text "NULL"
-expr2C (CharCode a) = do
- modify(\s -> s{lastType = BTChar})
- return $ quotes $ text "\\x" <> text (showHex (read a) "")
-expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
-expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
-
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
- e' <- liftM (map toLower . render) $ expr2C e
- lt <- gets lastType
- case lt of
- BTEnum a -> return $ int 0
- BTInt -> case e' of
- "longint" -> return $ int (-2147483648)
- BTArray {} -> return $ int 0
- _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
- e' <- liftM (map toLower . render) $ expr2C e
- lt <- gets lastType
- case lt of
- BTEnum a -> return . int $ length a - 1
- BTInt -> case e' of
- "longint" -> return $ int (2147483647)
- BTString -> return $ int 255
- BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
- _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
- e' <- expr2C e
- lt <- gets lastType
- modify (\s -> s{lastType = BTInt})
- case lt of
- BTString -> return $ text "fpcrtl_Length" <> parens e'
- BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
- BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
- _ -> error $ "length() called on " ++ show lt
-expr2C (BuiltInFunCall params ref) = do
- r <- ref2C ref
- t <- gets lastType
- ps <- mapM expr2C params
- case t of
- BTFunction _ _ t' -> do
- modify (\s -> s{lastType = t'})
- _ -> error $ "BuiltInFunCall lastType: " ++ show t
- return $
- r <> parens (hsep . punctuate (char ',') $ ps)
-expr2C a = error $ "Don't know how to render " ++ show a
-
-ref2CF :: Reference -> State RenderState Doc
-ref2CF (SimpleReference name) = do
- i <- id2C IOLookup name
- t <- gets lastType
- case t of
- BTFunction _ _ rt -> do
- modify(\s -> s{lastType = rt})
- return $ i <> parens empty --xymeng: removed parens
- _ -> return $ i
-ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
- i <- ref2C r
- t <- gets lastType
- case t of
- BTFunction _ _ rt -> do
- modify(\s -> s{lastType = rt})
- return $ i <> parens empty
- _ -> return $ i
-ref2CF r = ref2C r
-
-ref2C :: Reference -> State RenderState Doc
--- rewrite into proper form
-ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
-ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
-ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
-ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
-ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
--- conversion routines
-ref2C ae@(ArrayElement [expr] ref) = do
- e <- expr2C expr
- r <- ref2C ref
- t <- gets lastType
- case t of
- (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
--- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
--- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
- (BTString) -> modify (\st -> st{lastType = BTChar})
- (BTPointerTo t) -> do
- t'' <- fromPointer (show t) =<< gets lastType
- case t'' of
- BTChar -> modify (\st -> st{lastType = BTChar})
- a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
- a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
- case t of
- BTString -> return $ r <> text ".s" <> brackets e
- _ -> return $ r <> brackets e
-ref2C (SimpleReference name) = id2C IOLookup name
-ref2C rf@(RecordField (Dereference ref1) ref2) = do
- r1 <- ref2C ref1
- t <- fromPointer (show ref1) =<< gets lastType
- r2 <- case t of
- BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
- BTUnit -> error "What??"
- a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
- return $
- r1 <> text "->" <> r2
-ref2C rf@(RecordField ref1 ref2) = do
- r1 <- ref2C ref1
- t <- gets lastType
- case t of
- BTRecord _ rs -> do
- r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
- return $ r1 <> text "." <> r2
- BTUnit -> withLastIdNamespace $ ref2C ref2
- a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
-ref2C d@(Dereference ref) = do
- r <- ref2C ref
- t <- fromPointer (show d) =<< gets lastType
- modify (\st -> st{lastType = t})
- return $ (parens $ text "*" <> r)
-ref2C f@(FunCall params ref) = do
- r <- fref2C ref
- t <- gets lastType
- case t of
- BTFunction _ _ t' -> do
- ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
- modify (\s -> s{lastType = t'})
- return $ r <> ps
- _ -> case (ref, params) of
- (SimpleReference i, [p]) -> ref2C $ TypeCast i p
- _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
- where
- fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
- fref2C a = ref2C a
-
-ref2C (Address ref) = do
- r <- ref2C ref
- lt <- gets lastType
- case lt of
- BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
- _ -> return $ text "&" <> parens r
-ref2C (TypeCast t'@(Identifier i _) expr) = do
- lt <- expr2C expr >> gets lastType
- case (map toLower i, lt) of
- ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
- ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
- (a, _) -> do
- e <- expr2C expr
- t <- id2C IOLookup t'
- return . parens $ parens t <> e
-ref2C (RefExpression expr) = expr2C expr
-
-
-op2C :: String -> String
-op2C "or" = "|"
-op2C "and" = "&"
-op2C "not" = "~"
-op2C "xor" = "^"
-op2C "div" = "/"
-op2C "mod" = "%"
-op2C "shl" = "<<"
-op2C "shr" = ">>"
-op2C "<>" = "!="
-op2C "=" = "=="
-op2C "/" = "/(float)"
-op2C a = a
-
--- a/tools/unitCycles.hs Wed Apr 03 00:46:19 2013 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-module Main where
-
-import PascalParser
-import System
-import Control.Monad
-import Data.Either
-import Data.List
-import Data.Graph
-import Data.Maybe
-
-unident :: Identificator -> String
-unident (Identificator s) = s
-
-extractUnits :: PascalUnit -> (String, [String])
-extractUnits (Program (Identificator name) (Implementation (Uses idents) _ _) _) = ("program " ++ name, map unident idents)
-extractUnits (Unit (Identificator name) (Interface (Uses idents1) _) (Implementation (Uses idents2) _ _) _ _) = (name, map unident $ idents1 ++ idents2)
-
-f :: [(String, [String])] -> String
-f = unlines . map showSCC . stronglyConnComp . map (\(a, b) -> (a, a, b))
- where
- showSCC (AcyclicSCC v) = v
- showSCC (CyclicSCC vs) = intercalate ", " vs
-
-myf :: [(String, [String])] -> String
-myf d = unlines . map (findCycle . fst) $ d
- where
- findCycle :: String -> String
- findCycle searched = searched ++ ": " ++ (intercalate ", " $ fc searched [])
- where
- fc :: String -> [String] -> [String]
- fc curSearch visited = let uses = curSearch `lookup` d; res = dropWhile null . map t $ fromJust uses in if isNothing uses || null res then [] else head res
- where
- t u =
- if u == searched then
- [u]
- else
- if u `elem` visited then
- []
- else
- let chain = fc u (u:visited) in if null chain then [] else u:chain
-
-
-main = do
- fileNames <- getArgs
- files <- mapM readFile fileNames
- putStrLn . myf . map extractUnits . rights . map parsePascalUnit $ files