# HG changeset patch # User unc0rr # Date 1392067184 -14400 # Node ID cd2a64a1f4aa4070c7747df80aed7f3ae3335983 # Parent 0f6878b5395adbe683beac4e536260bc974c51c8 - Pas2C: make use of 'external' function decorator - Fixes to rtl - Some work here and there diff -r 0f6878b5395a -r cd2a64a1f4aa hedgewars/pas2cSystem.pas --- a/hedgewars/pas2cSystem.pas Mon Feb 10 23:02:49 2014 +0400 +++ b/hedgewars/pas2cSystem.pas Tue Feb 11 01:19:44 2014 +0400 @@ -127,7 +127,7 @@ clear_filelist_hook, add_file_hook, idb_loader_hook, mainloop_hook, drawworld_hook : procedure; SDL_InitPatch : procedure; - PHYSFS_init, PHYSFS_deinit, PHYSFS_mount, PHYSFS_readBytes : function : LongInt; + PHYSFS_init, PHYSFS_deinit, PHYSFS_mount, PHYSFS_readBytes, PHYSFS_read : function : LongInt; PHYSFSRWOPS_openRead, PHYSFSRWOPS_openWrite, PHYSFS_openRead : function : pointer; PHYSFS_eof, PHYSFS_close, PHYSFS_exists : function : boolean; PHYSFS_getLastError : function : PChar; diff -r 0f6878b5395a -r cd2a64a1f4aa hedgewars/uPhysFSLayer.pas --- a/hedgewars/uPhysFSLayer.pas Mon Feb 10 23:02:49 2014 +0400 +++ b/hedgewars/uPhysFSLayer.pas Tue Feb 11 01:19:44 2014 +0400 @@ -1,3 +1,5 @@ +{$INCLUDE "options.inc"} + unit uPhysFSLayer; interface @@ -29,21 +31,19 @@ function pfsExists(fname: shortstring): boolean; -{$IFNDEF PAS2C} function physfsReader(L: Plua_State; f: PFSFile; sz: Psize_t) : PChar; cdecl; external PhyslayerLibName; procedure physfsReaderSetBuffer(buf: pointer); cdecl; external PhyslayerLibName; procedure hedgewarsMountPackage(filename: PChar); cdecl; external PhyslayerLibName; -{$ENDIF} implementation -uses uConsts, uUtils, uVariables{$IFNDEF PAS2C}, sysutils{$ENDIF}; +uses uConsts, uUtils, uVariables{$IFNDEF PAS2C}, sysutils{$ELSE}, physfs{$ENDIF}; -{$IFNDEF PAS2C} -function PHYSFS_init(argv0: PChar) : LongInt; cdecl; external PhysfsLibName; -function PHYSFS_deinit() : LongInt; cdecl; external PhysfsLibName; function PHYSFSRWOPS_openRead(fname: PChar): PSDL_RWops; cdecl; external PhyslayerLibName; function PHYSFSRWOPS_openWrite(fname: PChar): PSDL_RWops; cdecl; external PhyslayerLibName; - +procedure hedgewarsMountPackages(); cdecl; external PhyslayerLibName; +{$IFNDEF PAS2C} +function PHYSFS_init(argv0: PChar): LongInt; cdecl; external PhysfsLibName; +function PHYSFS_deinit(): LongInt; cdecl; external PhysfsLibName; function PHYSFS_mount(newDir, mountPoint: PChar; appendToPath: LongBool) : LongBool; cdecl; external PhysfsLibName; function PHYSFS_openRead(fname: PChar): PFSFile; cdecl; external PhysfsLibName; function PHYSFS_eof(f: PFSFile): LongBool; cdecl; external PhysfsLibName; @@ -51,8 +51,11 @@ function PHYSFS_close(f: PFSFile): LongBool; cdecl; external PhysfsLibName; function PHYSFS_exists(fname: PChar): LongBool; cdecl; external PhysfsLibName; function PHYSFS_getLastError(): PChar; cdecl; external PhysfsLibName; - -procedure hedgewarsMountPackages(); cdecl; external PhyslayerLibName; +{$ELSE} +function PHYSFS_readBytes(f: PFSFile; buffer: pointer; len: Int64): Int64; +begin + PHYSFS_readBytes:= PHYSFS_read(f, buffer, 1, len); +end; {$ENDIF} function rwopsOpenRead(fname: shortstring): PSDL_RWops; @@ -142,7 +145,7 @@ procedure pfsMountAtRoot(path: ansistring); begin - pfsMount(path, PChar('/')); + pfsMount(path, PChar(_S'/')); end; procedure initModule; diff -r 0f6878b5395a -r cd2a64a1f4aa hedgewars/uScript.pas --- a/hedgewars/uScript.pas Mon Feb 10 23:02:49 2014 +0400 +++ b/hedgewars/uScript.pas Tue Feb 11 01:19:44 2014 +0400 @@ -86,9 +86,7 @@ uVisualGearsList, uGearsHandlersMess, uPhysFSLayer -{$IFDEF PAS2C} - , hwpacksmounter -{$ELSE} +{$IFNDEF PAS2C} , typinfo {$ENDIF} ; diff -r 0f6878b5395a -r cd2a64a1f4aa hedgewars/uStore.pas --- a/hedgewars/uStore.pas Mon Feb 10 23:02:49 2014 +0400 +++ b/hedgewars/uStore.pas Tue Feb 11 01:19:44 2014 +0400 @@ -600,7 +600,8 @@ if tmpsurf = nil then begin - OutError(msgFailed, (imageFlags and ifCritical) <> 0); + OutError(msgFailed, false); + SDLTry(false, (imageFlags and ifCritical) <> 0); exit; end; diff -r 0f6878b5395a -r cd2a64a1f4aa misc/libphyslayer/physfsrwops.h --- a/misc/libphyslayer/physfsrwops.h Mon Feb 10 23:02:49 2014 +0400 +++ b/misc/libphyslayer/physfsrwops.h Tue Feb 11 01:19:44 2014 +0400 @@ -24,6 +24,7 @@ #define _INCLUDE_PHYSFSRWOPS_H_ #include "physfs.h" + #include "SDL.h" #include "physfscompat.h" diff -r 0f6878b5395a -r cd2a64a1f4aa project_files/hwc/CMakeLists.txt --- a/project_files/hwc/CMakeLists.txt Mon Feb 10 23:02:49 2014 +0400 +++ b/project_files/hwc/CMakeLists.txt Tue Feb 11 01:19:44 2014 +0400 @@ -13,6 +13,7 @@ include_directories(${PHYSFS_INCLUDE_DIR}) include_directories(${PHYSLAYER_INCLUDE_DIR}) include_directories(${LUA_INCLUDE_DIR}) +include_directories(${SDL_INCLUDE_DIR}) add_subdirectory(rtl) configure_file(${CMAKE_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc) diff -r 0f6878b5395a -r cd2a64a1f4aa project_files/hwc/rtl/fpcrtl.h --- a/project_files/hwc/rtl/fpcrtl.h Mon Feb 10 23:02:49 2014 +0400 +++ b/project_files/hwc/rtl/fpcrtl.h Tue Feb 11 01:19:44 2014 +0400 @@ -148,8 +148,8 @@ #define sdlh_SDL_WaitThread SDL_WaitThread #define sdlh_SDL_CreateMutex SDL_CreateMutex #define sdlh_SDL_DestroyMutex SDL_DestroyMutex -#define sdlh_SDL_LockMutex SDL_mutexP -#define sdlh_SDL_UnlockMutex SDL_mutexV +#define SDL_LockMutex SDL_mutexP +#define SDL_UnlockMutex SDL_mutexV #ifndef EMSCRIPTEN #define sdlh_SDL_ShowCursor SDL_ShowCursor #else @@ -181,6 +181,14 @@ #define sdlh_TTF_SetFontStyle TTF_SetFontStyle #define sdlh_TTF_SizeUTF8 TTF_SizeUTF8 +#define uphysfslayer_physfsReaderSetBuffer physfsReaderSetBuffer +#define uphysfslayer_physfsReader physfsReader +#define uphysfslayer_hedgewarsMountPackage hedgewarsMountPackage +#define uphysfslayer_hedgewarsMountPackages hedgewarsMountPackages + +#define uphysfslayer_PHYSFSRWOPS_openRead PHYSFSRWOPS_openRead +#define uphysfslayer_PHYSFSRWOPS_openWrite PHYSFSRWOPS_openWrite + #define _strconcat fpcrtl_strconcat #define _strappend fpcrtl_strappend #define _strprepend fpcrtl_strprepend diff -r 0f6878b5395a -r cd2a64a1f4aa project_files/hwc/rtl/misc.c --- a/project_files/hwc/rtl/misc.c Mon Feb 10 23:02:49 2014 +0400 +++ b/project_files/hwc/rtl/misc.c Tue Feb 11 01:19:44 2014 +0400 @@ -57,7 +57,7 @@ int newlen = str1.len + str2.len; if(newlen > MAX_ANSISTRING_LENGTH) newlen = MAX_ANSISTRING_LENGTH; - memcpy(&(str1.s[str1.len + 1]), str2.s[1], newlen - str1.len); + memcpy(&(str1.s[str1.len + 1]), &str2.s[1], newlen - str1.len); str1.len = newlen; return str1; @@ -67,8 +67,8 @@ { if(s.len < 255) { + ++s.len; s.s[s.len] = c; - ++s.len; } return s; @@ -195,16 +195,9 @@ char* fpcrtl__pchar__vars(string255 * s) { - if(s->len < 255) - { - s->s[s->len] = 0; - return &s->s[1]; - } else - { - memcpy(__pcharBuf, s->s[1], 255); - __pcharBuf[255] = 0; - return &__pcharBuf; - } + memcpy(__pcharBuf, &s->s[1], s->len); + __pcharBuf[s->len] = 0; + return __pcharBuf; } char* fpcrtl__pcharA__vars(astring * s) diff -r 0f6878b5395a -r cd2a64a1f4aa project_files/hwc/rtl/misc.h --- a/project_files/hwc/rtl/misc.h Mon Feb 10 23:02:49 2014 +0400 +++ b/project_files/hwc/rtl/misc.h Tue Feb 11 01:19:44 2014 +0400 @@ -51,6 +51,7 @@ #define fpcrtl__pchar(s) fpcrtl__pchar__vars(&(s)) #define fpcrtl__pcharA(s) fpcrtl__pcharA__vars(&(s)) char* fpcrtl__pchar__vars(string255 * s); +char* fpcrtl__pcharA__vars(astring * s); string255 fpcrtl_pchar2str(const char *s); astring fpcrtl_pchar2astr(const char *s); astring fpcrtl_str2astr(string255 s); diff -r 0f6878b5395a -r cd2a64a1f4aa tools/pas2c/Pas2C.hs --- a/tools/pas2c/Pas2C.hs Mon Feb 10 23:02:49 2014 +0400 +++ b/tools/pas2c/Pas2C.hs Tue Feb 11 01:19:44 2014 +0400 @@ -237,7 +237,7 @@ pascal2C (Program _ implementation mainFunction) = do impl <- implementation2C implementation - [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) + [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) return $ impl $+$ main @@ -271,7 +271,7 @@ initMap :: Map.Map String Int initMap = Map.empty --initMap = Map.fromList [("reset", 2)] - ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m + 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 @@ -310,8 +310,8 @@ tom <- gets (Set.member n . toMangle) cu <- gets currentUnit let (i', t') = case (t, tom) of - (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) - (BTFunction _ _ _, _) -> (cu ++ i, t) + (BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t) + (BTFunction _ e _ _, _) -> ((if e then id else (++) cu) i, t) (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'') _ -> (i, t) modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) @@ -331,7 +331,7 @@ let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) where - checkParam (Record _ (BTFunction _ p _) _) = (length p) == params + checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params checkParam _ = False id2C IODeferred (Identifier i _) = do let i' = map toLower i @@ -417,7 +417,7 @@ resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t resolveType (FunctionType t a) = do bts <- typeVarDecl2BaseType a - liftM (BTFunction False bts) $ resolveType t + liftM (BTFunction False False bts) $ resolveType t resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) resolveType (DeriveType (InitNumber _)) = return (BTInt True) resolveType (DeriveType (InitFloat _)) = return BTFloat @@ -481,16 +481,16 @@ ps = zip ['a'..] (toIsVarList params) fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] -fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do +fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do t <- type2C returnType t'<- gets lastType bts <- typeVarDecl2BaseType params p <- withState' id $ functionParams2C params - n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name + n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name let decor = if overload then text "__attribute__((overloadable))" else empty return [t empty <+> decor <+> text n <> parens p] -fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do +fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do let isVoid = case returnType of VoidType -> True _ -> False @@ -503,12 +503,12 @@ --cu <- gets currentUnit notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope - n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name + n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name let resultId = if isVoid then n -- void type doesn't have result, solving recursive procedure calls else (render res) - (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars bts t') else t') empty] $ currentScope st + (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st , currentFunctionResult = if isVoid then [] else render res}) $ do p <- functionParams2C params ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) @@ -539,14 +539,14 @@ un _ _ = error "fun2C u: pattern not matched" hasVars = hasPassByReference params -fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name +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 +tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do t <- fun2C b name f if includeType then return t else return [] tvar2C _ _ includeType _ (TypeDeclaration i' t) = do @@ -612,7 +612,7 @@ tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do r <- op2CTyped op (extractTypes params) - fun2C f i (FunctionDeclaration r inline False ret params body) + fun2C f i (FunctionDeclaration r inline False False ret params body) op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier @@ -647,7 +647,7 @@ ie <- initExpr2C' expr lt <- gets lastType case lt of - BTFunction True _ _ -> return $ text "&" <> ie -- <> text "__vars" + 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 @@ -941,26 +941,26 @@ e2 <- expr2C expr2 t2 <- gets lastType case (op2C op, t1, t2) of - ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (BTFunction False [(False, t1), (False, t2)] BTString)) - ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (BTFunction False [(False, t1), (False, t2)] BTAString)) - ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (BTFunction False [(False, t1), (False, t2)] BTBool)) + ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString)) + ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2 BTAString)) + ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2 BTBool)) (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop - ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) - ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString)) - ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString)) - ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) - ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool)) + ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2 BTString)) + ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2 BTString)) + ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2 BTString)) + ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2 BTString)) + ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2 BTBool)) -- for function/procedure comparision ("==", BTVoid, _) -> procCompare expr1 expr2 "==" - ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "==" + ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "==" ("!=", BTVoid, _) -> procCompare expr1 expr2 "!=" - ("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!=" + ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!=" - ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) - ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) + ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2 BTBool)) + ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2 BTBool)) ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 (_, BTRecord t1 _, BTRecord t2 _) -> do @@ -992,6 +992,7 @@ _ -> parens e2 return $ e1' <+> o' <+> e2' where + fff t1 t2 = BTFunction False False [(False, t1), (False, t2)] boolOps = ["==", "!=", "<", ">", "<=", ">="] procCompare expr1 expr2 op = case (expr1, expr2) of @@ -1088,7 +1089,7 @@ t <- gets lastType ps <- mapM expr2C params case t of - BTFunction _ _ t' -> do + BTFunction _ _ _ t' -> do modify (\s -> s{lastType = t'}) _ -> error $ "BuiltInFunCall lastType: " ++ show t return $ @@ -1100,7 +1101,7 @@ i <- id2C IOLookup name t <- gets lastType case t of - BTFunction _ _ rt -> do + BTFunction _ _ _ rt -> do modify(\s -> s{lastType = rt}) return $ if addParens then i <> parens empty else i --xymeng: removed parens _ -> return $ i @@ -1108,7 +1109,7 @@ i <- ref2C r t <- gets lastType case t of - BTFunction _ _ rt -> do + BTFunction _ _ _ rt -> do modify(\s -> s{lastType = rt}) return $ if addParens then i <> parens empty else i _ -> return $ i @@ -1170,7 +1171,7 @@ r <- fref2C ref t <- gets lastType case t of - BTFunction _ bts t' -> do + BTFunction _ _ bts t' -> do ps <- liftM (parens . hsep . punctuate (char ',')) $ if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params then @@ -1185,7 +1186,7 @@ fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name fref2C a = ref2C a expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc - expr2CHelper (e, (_, BTFunction _ _ _)) = do + expr2CHelper (e, (_, BTFunction _ _ _ _)) = do modify (\s -> s{isFunctionType = True}) expr2C e expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e @@ -1194,7 +1195,7 @@ r <- ref2C ref lt <- gets lastType case lt of - BTFunction True _ _ -> return $ text "&" <> parens r + BTFunction True _ _ _ -> return $ text "&" <> parens r _ -> return $ text "&" <> parens r ref2C (TypeCast t'@(Identifier i _) expr) = do lt <- expr2C expr >> gets lastType diff -r 0f6878b5395a -r cd2a64a1f4aa tools/pas2c/PascalParser.hs --- a/tools/pas2c/PascalParser.hs Mon Feb 10 23:02:49 2014 +0400 +++ b/tools/pas2c/PascalParser.hs Tue Feb 11 01:19:44 2014 +0400 @@ -329,11 +329,13 @@ decorators <- many functionDecorator let inline = any (== "inline;") decorators overload = any (== "overload;") decorators - b <- if isImpl && (not forward) then + external = any (== "external;") decorators + -- TODO: don't mangle external functions names (and remove fpcrtl.h defines hacks) + b <- if isImpl && (not forward) && (not external) then liftM Just functionBody else return Nothing - return $ [FunctionDeclaration i inline overload ret vs b] + return $ [FunctionDeclaration i inline overload external ret vs b] functionDecorator = do d <- choice [ @@ -342,7 +344,8 @@ , try $ string "overload;" , try $ string "export;" , try $ string "varargs;" - , try (string' "external") >> comments >> iD >> optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external" + , try (string' "external") >> comments >> iD >> comments >> + optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external;" ] comments return d diff -r 0f6878b5395a -r cd2a64a1f4aa tools/pas2c/PascalUnitSyntaxTree.hs --- a/tools/pas2c/PascalUnitSyntaxTree.hs Mon Feb 10 23:02:49 2014 +0400 +++ b/tools/pas2c/PascalUnitSyntaxTree.hs Tue Feb 11 01:19:44 2014 +0400 @@ -16,7 +16,7 @@ deriving Show data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression) - | FunctionDeclaration Identifier Bool Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) + | FunctionDeclaration Identifier Bool Bool Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) deriving Show data TypeDecl = SimpleType Identifier @@ -107,7 +107,7 @@ | BTFloat | BTRecord String [(String, BaseType)] | BTArray Range BaseType BaseType - | BTFunction Bool [(Bool, BaseType)] BaseType -- (Bool, BaseType), Bool indiciates whether var or not + | BTFunction Bool Bool [(Bool, BaseType)] BaseType -- in (Bool, BaseType), Bool indiciates whether var or not | BTPointerTo BaseType | BTUnresolved String | BTSet BaseType