# HG changeset patch # User koda # Date 1353541313 -3600 # Node ID 453917e94e55344cfba9edb1b25d39c8592bb66d # Parent 2e836bebb518ea9e1dd90af025505b06c8c63d0d# Parent 2286a39140da4c75c0105b55e3533c73e10b04d4 updated branch diff -r 2286a39140da -r 453917e94e55 .hgignore --- a/.hgignore Wed Nov 21 23:34:54 2012 +0100 +++ b/.hgignore Thu Nov 22 00:41:53 2012 +0100 @@ -39,6 +39,8 @@ glob:*.orig glob:*.bak glob:*.rej +glob:project_files/hwc/*.c +glob:project_files/hwc/*.h glob:project_files/Android-build/SDL-android-project/jni/** glob:project_files/Android-build/SDL-android-project/obj glob:project_files/Android-build/SDL-android-project/libs/armeabi* diff -r 2286a39140da -r 453917e94e55 CMakeLists.txt --- a/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -18,12 +18,17 @@ option(NOPNG "Disable screenshoot compression [default: auto]" OFF) option(NOVIDEOREC "Disable video recording [default: auto]" OFF) -option(BUILD_ENGINE_LIBRARY "Enable hwengine library [default: off]" OFF) + +option(WEBGL "Enable WebGL build (implies NOPASCAL) [default: off]" OFF) +option(NOPASCAL "Compile hwengine as native C [default: off]" ${WEBGL}) +option(LIBENGINE "Enable hwengine library [default: off]" OFF) + option(ANDROID "Enable Android build [default: off]" OFF) option(NOAUTOUPDATE "Disable OS X Sparkle update checking" OFF) option(CROSSAPPLE "Enable OSX when not on OSX [default: off]" OFF) option(MINIMAL_FLAGS "Respect system flags as much as possible [default: off]" OFF) + #detect Mercurial revision (if present) IF(NOT NOREVISION) set(default_build_type "DEBUG") @@ -220,8 +225,9 @@ link_directories("${EXECUTABLE_OUTPUT_PATH}" "${CMAKE_SOURCE_DIR}/misc/winutils/bin") endif(WIN32) -#server discovery -if(NOT NOSERVER) + +#Haskell compiler discovery (for server and engine in c) +if((NOT NOSERVER) OR NOPASCAL) if(GHC) set(ghc_executable ${GHC}) else() @@ -229,53 +235,73 @@ endif() if(ghc_executable) - set(HAVE_NETSERVER true) - add_subdirectory(gameServer) - message(STATUS "Found GHC: ${ghc_executable}") + exec_program(${ghc_executable} ARGS "-V" OUTPUT_VARIABLE ghc_version_long) + string(REGEX REPLACE ".*([0-9]+\\.[0-9]+\\.[0-9]+)" "\\1" ghc_version "${ghc_version_long}") + message(STATUS "Found GHC: ${ghc_executable} (version ${ghc_version})") else() - message(WARNING "Could NOT find GHC, server will not be built") - set(HAVE_NETSERVER false) + message(STATUS "Could NOT find GHC, needed by gameServer and pas2c") endif() +endif() + + +#check gameServer +if((ghc_executable) AND (NOT NOSERVER) AND (NOT WEBGL)) + set(HAVE_NETSERVER true) + add_subdirectory(gameServer) else() - message(STATUS "Server will not be built per user request") + message(STATUS "Skipping gameServer target") set(HAVE_NETSERVER false) endif() #lua discovery find_package(Lua) -if(LUA_FOUND) +if(LUA_FOUND AND (NOT WEBGL)) message(STATUS "Found LUA: ${LUA_DEFAULT}") else() - message(STATUS "LUA will be provided by the bundled sources") + message(STATUS "Using internal LUA library") add_subdirectory(misc/liblua) #linking with liblua.a requires system readline set(pascal_flags "-k${EXECUTABLE_OUTPUT_PATH}/lib${LUA_LIBRARY}.a" "-k-lreadline" ${pascal_flags}) endif() -#main engine -add_subdirectory(hedgewars) - #physfs library add_subdirectory(misc/physfs) #frontend library add_subdirectory(project_files/frontlib) -#Android related build scripts -if(ANDROID) - #run cmake -DANDROID=1 to enable this - add_subdirectory(project_files/Android-build) + +if(NOPASCAL) + if (NOT ghc_executable) + message(FATAL_ERROR "A Haskell compiler is required to build engine in C") + endif() + #pascal to c converter + add_subdirectory(tools/pas2c) + add_subdirectory(project_files/hwc) +else() + #main pascal engine + add_subdirectory(hedgewars) endif() -#TODO: when ANDROID, BUILD_ENGINE_LIBRARY should be set -if(NOT ANDROID) - add_subdirectory(bin) - add_subdirectory(QTfrontend) - add_subdirectory(share) - add_subdirectory(tools) -endif() +if(WEBGL) + #WEBGL deps +else(WEBGL) + #Android related build scripts + if(ANDROID) + add_subdirectory(project_files/Android-build) + endif() + + #TODO: when ANDROID, BUILD_ENGINE_LIBRARY should be set + if(NOT ANDROID) + add_subdirectory(bin) + add_subdirectory(QTfrontend) + add_subdirectory(share) + add_subdirectory(tools) + endif() +endif(WEBGL) + # CPack variables diff -r 2286a39140da -r 453917e94e55 cmake_modules/FindGLEW.cmake --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cmake_modules/FindGLEW.cmake Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,64 @@ +# +# Try to find GLEW library and include path. +# Once done this will define +# +# GLEW_FOUND +# GLEW_INCLUDE_PATH +# GLEW_LIBRARY +# + +if (GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + # in cache already + set(GLEW_FOUND TRUE) +else (GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + + IF (WIN32) + FIND_PATH( GLEW_INCLUDE_PATH GL/glew.h + $ENV{PROGRAMFILES}/GLEW/include + ${PROJECT_SOURCE_DIR}/src/nvgl/glew/include + DOC "The directory where GL/glew.h resides") + FIND_LIBRARY( GLEW_LIBRARY + NAMES glew GLEW glew32 glew32s + PATHS + $ENV{PROGRAMFILES}/GLEW/lib + ${PROJECT_SOURCE_DIR}/src/nvgl/glew/bin + ${PROJECT_SOURCE_DIR}/src/nvgl/glew/lib + DOC "The GLEW library") + ELSE (WIN32) + FIND_PATH( GLEW_INCLUDE_PATH GL/glew.h + /usr/include + /usr/local/include + /sw/include + /opt/local/include + DOC "The directory where GL/glew.h resides") + FIND_LIBRARY( GLEW_LIBRARY + NAMES GLEW glew + PATHS + /usr/lib64 + /usr/lib + /usr/local/lib64 + /usr/local/lib + /sw/lib + /opt/local/lib + DOC "The GLEW library") + ENDIF (WIN32) + + IF (GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + SET( GLEW_FOUND 1 CACHE STRING "Set to 1 if GLEW is found, 0 otherwise") + ELSE (GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + SET( GLEW_FOUND 0 CACHE STRING "Set to 1 if GLEW is found, 0 otherwise") + ENDIF (GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + +endif(GLEW_LIBRARY AND GLEW_INCLUDE_PATH) + +if (GLEW_FOUND) + if (NOT GLEW_FIND_QUIETLY) + message(STATUS "Found GLEW: ${GLEW_LIBRARY}, ${GLEW_INCLUDE_PATH}") + endif (NOT GLEW_FIND_QUIETLY) +else (GLEW_FOUND) + if (GLEW_FIND_REQUIRED) + message(FATAL_ERROR "Could NOT find GLEW") + endif (GLEW_FIND_REQUIRED) +endif (GLEW_FOUND) + +#MARK_AS_ADVANCED( GLEW_FOUND ) \ No newline at end of file diff -r 2286a39140da -r 453917e94e55 gameServer/CMakeLists.txt --- a/gameServer/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/gameServer/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -23,11 +23,11 @@ hedgewars-server.hs ) -set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs) +set(hwserv_main ${CMAKE_SOURCE_DIR}/gameServer/hedgewars-server.hs) set(ghc_flags --make ${hwserv_main} - -i${hedgewars_SOURCE_DIR}/gameServer + -i${CMAKE_CURRENT_SOURCE_DIR} -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX} -odir ${CMAKE_CURRENT_BINARY_DIR} -hidir ${CMAKE_CURRENT_BINARY_DIR} diff -r 2286a39140da -r 453917e94e55 gameServer/hedgewars-server.cabal --- a/gameServer/hedgewars-server.cabal Wed Nov 21 23:34:54 2012 +0100 +++ b/gameServer/hedgewars-server.cabal Thu Nov 22 00:41:53 2012 +0100 @@ -16,7 +16,6 @@ Build-depends: base >= 4.3, - unix, containers, vector, bytestring, diff -r 2286a39140da -r 453917e94e55 hedgewars/CMakeLists.txt --- a/hedgewars/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -6,10 +6,10 @@ include(${CMAKE_SOURCE_DIR}/cmake_modules/FindSDL_Extras.cmake) -configure_file(${hedgewars_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc) +configure_file(${CMAKE_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc) #SOURCE AND PROGRAMS SECTION -set(hwengine_project ${hedgewars_SOURCE_DIR}/hedgewars/hwengine.pas) +set(hwengine_project ${CMAKE_SOURCE_DIR}/hedgewars/hwengine.pas) set(engine_output_name "hwengine") set(engine_sources @@ -52,6 +52,7 @@ uLandTemplates.pas uLandTexture.pas uLocale.pas + uMatrix.pas uMisc.pas uMobile.pas uPhysFSLayer.pas @@ -80,9 +81,9 @@ ${CMAKE_CURRENT_BINARY_DIR}/config.inc ) -if(BUILD_ENGINE_LIBRARY) +if(LIBENGINE) message(STATUS "Engine will be built as library (experimental)") - set(hwengine_project ${hedgewars_SOURCE_DIR}/hedgewars/hwLibrary.pas) + set(hwengine_project ${CMAKE_SOURCE_DIR}/hedgewars/hwLibrary.pas) set(pascal_flags "-dHWLIBRARY" ${pascal_flags}) # create position independent code, only required for x68_64 builds, similar to -fPIC @@ -98,7 +99,7 @@ if(APPLE) set(engine_output_name "libhwengine.dylib") endif (APPLE) -endif(BUILD_ENGINE_LIBRARY) +endif(LIBENGINE) #PASCAL DETECTION SECTION @@ -161,7 +162,7 @@ endif() #on OSX we need to provide the SDL_main() function when building as executable - if(NOT BUILD_ENGINE_LIBRARY) + if(NOT LIBENGINE) #let's look for the installed sdlmain file; if it is not found, let's build our own find_package(SDL REQUIRED) #remove the ";-framework Cocoa" from the SDL_LIBRARY variable @@ -171,7 +172,7 @@ if(SDLMAIN_LIB MATCHES "SDLMAIN_LIB-NOTFOUND") include_directories(${SDL_INCLUDE_DIR}) - add_library (SDLmain STATIC SDLMain.m) + add_library (SDLmain STATIC sdlmain_osx/SDLMain.m) #add a dependency to the hwengine target set(engine_sources ${engine_sources} SDLmain) set(SDLMAIN_LIB "${LIBRARY_OUTPUT_PATH}/libSDLmain.a") @@ -206,7 +207,7 @@ else() set(SAFE_BUILD_TOOL ${CMAKE_BUILD_TOOL}) endif() - add_custom_target(ENGINECLEAN COMMAND ${SAFE_BUILD_TOOL} "clean" "${PROJECT_BINARY_DIR}" "${hedgewars_SOURCE_DIR}/hedgewars") + add_custom_target(ENGINECLEAN COMMAND ${SAFE_BUILD_TOOL} "clean" "${PROJECT_BINARY_DIR}" "${CMAKE_SOURCE_DIR}/hedgewars") endif() @@ -223,11 +224,11 @@ set(pascal_flags "-dUSE_VIDEO_RECORDING" ${pascal_flags}) IF (WIN32) # there are some problems with linking our avwrapper as static lib, so link it as shared - add_library(avwrapper SHARED avwrapper.c) + add_library(avwrapper SHARED videorec/avwrapper.c) target_link_libraries(avwrapper ${FFMPEG_LIBRARIES}) install(PROGRAMS "${EXECUTABLE_OUTPUT_PATH}/${CMAKE_SHARED_LIBRARY_PREFIX}avwrapper${CMAKE_SHARED_LIBRARY_SUFFIX}" DESTINATION ${target_dir}) ELSE() - add_library(avwrapper STATIC avwrapper.c) + add_library(avwrapper STATIC videorec/avwrapper.c) set(pascal_flags "-k${FFMPEG_LIBAVCODEC}" "-k${FFMPEG_LIBAVFORMAT}" "-k${FFMPEG_LIBAVUTIL}" ${pascal_flags}) ENDIF() else() diff -r 2286a39140da -r 453917e94e55 hedgewars/GL.h --- a/hedgewars/GL.h Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -#pragma once - -#include diff -r 2286a39140da -r 453917e94e55 hedgewars/GSHandlers.inc --- a/hedgewars/GSHandlers.inc Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/GSHandlers.inc Thu Nov 22 00:41:53 2012 +0100 @@ -173,7 +173,7 @@ land: word; begin // clip velocity at 2 - over 1 per pixel, but really shouldn't cause many actual problems. -{$IFNDEF WEB} +{$IFNDEF WEBGL} if Gear^.dX.Round > 2 then Gear^.dX.QWordValue:= 8589934592; if Gear^.dY.Round > 2 then @@ -999,7 +999,8 @@ procedure doStepBulletWork(Gear: PGear); var - i, x, y: LongWord; + i: LongInt; + x, y: LongWord; oX, oY: hwFloat; VGear: PVisualGear; begin @@ -2747,6 +2748,7 @@ procedure doStepSeductionWork(Gear: PGear); var i: LongInt; hogs: PGearArrayS; + len: Integer; begin AllInactive := false; hogs := GearsNear(Gear^.X, Gear^.Y, gtHedgehog, Gear^.Radius); @@ -3519,7 +3521,9 @@ i: LongInt; begin AllInactive := false; + {$IFNDEF PAS2C} Gear^.dX := Gear^.dX; + {$ENDIF} doStepFallingGear(Gear); // CheckGearDrowning(Gear); // already checked for in doStepFallingGear CalcRotationDirAngle(Gear); @@ -4620,6 +4624,7 @@ resgear: PGear; hh: PHedgehog; i: LongInt; + len: Integer; begin if (TurnTimeLeft > 0) then dec(TurnTimeLeft); @@ -4711,6 +4716,7 @@ var graves: PGearArrayS; i: LongInt; + len: Integer; begin AllInactive := false; graves := GearsNear(Gear^.X, Gear^.Y, gtGrave, Gear^.Radius); @@ -5034,12 +5040,14 @@ A frozen hog will animate differently. To be decided, but possibly in a similar fashion to a grave when it comes to explosions. The hog might (possibly) not be damaged by explosions. This might make freezing potentially useful for friendlies in a bad position. It might be better to allow damage though. A frozen hog stays frozen for a certain number of turns. Each turn the frozen overlay becomes fainter, until it fades and the hog animates normally again. *) + procedure doStepIceGun(Gear: PGear); var HHGear: PGear; ndX, ndY: hwFloat; i, t, gX, gY: LongInt; hogs: PGearArrayS; + len: Integer; begin HHGear := Gear^.Hedgehog^.Gear; if (Gear^.Health = 0) or (HHGear = nil) or (HHGear^.Damage <> 0) then diff -r 2286a39140da -r 453917e94e55 hedgewars/LuaPas.pas --- a/hedgewars/LuaPas.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/LuaPas.pas Thu Nov 22 00:41:53 2012 +0100 @@ -54,12 +54,14 @@ @* of a function in debug information. ** CHANGE it if you want a different size. *) + const LUA_IDSIZE = 60; (* @@ LUAL_BUFFERSIZE is the buffer size used by the lauxlib buffer system. *) + const LUAL_BUFFERSIZE = 1024; @@ -69,6 +71,7 @@ ** CHANGE them if you want different prompts. (You can also change the ** prompts dynamically, assigning to globals _PROMPT/_PROMPT2.) *) + const LUA_PROMPT = '> '; LUA_PROMPT2 = '>> '; @@ -112,6 +115,7 @@ ** See Copyright Notice at the end of this file *) + const LUA_VERSION = 'Lua 5.1'; LUA_VERSION_NUM = 501; @@ -131,8 +135,10 @@ LUA_ENVIRONINDEX = -10001; LUA_GLOBALSINDEX = -10002; + function lua_upvalueindex(idx : LongInt) : LongInt; // a marco + const (* thread status; 0 is OK *) LUA_YIELD_ = 1; // Note: the ending underscore is needed in Pascal @@ -141,6 +147,7 @@ LUA_ERRMEM = 4; LUA_ERRERR = 5; + type lua_CFunction = function(L : Plua_State) : LongInt; cdecl; @@ -155,6 +162,7 @@ *) lua_Alloc = function (ud, ptr : Pointer; osize, nsize : size_t) : Pointer; cdecl; + const (* ** basic types @@ -180,6 +188,7 @@ (* type for integer functions *) lua_Integer = LUA_INTEGER_; + (* ** state manipulation *) @@ -240,10 +249,9 @@ function lua_type(L : Plua_State; idx : LongInt) : LongInt; cdecl; external LuaLibName; - + function lua_typename(L : Plua_State; tp : LongInt) : PChar; cdecl; external LuaLibName; - function lua_equal(L : Plua_State; idx1, idx2 : LongInt) : LongBool; cdecl; external LuaLibName; @@ -263,10 +271,9 @@ function lua_toboolean(L : Plua_State; idx : LongInt) : LongBool; cdecl; external LuaLibName; - function lua_tolstring(L : Plua_State; idx : LongInt; len : Psize_t) : PChar; cdecl; external LuaLibName; - + function lua_objlen(L : Plua_State; idx : LongInt) : size_t; cdecl; external LuaLibName; @@ -294,14 +301,13 @@ procedure lua_pushinteger(L : Plua_State; n : lua_Integer); cdecl; external LuaLibName; - + procedure lua_pushlstring(L : Plua_State; const s : PChar; ls : size_t); cdecl; external LuaLibName; procedure lua_pushstring(L : Plua_State; const s : PChar); cdecl; external LuaLibName; - function lua_pushvfstring(L : Plua_State; const fmt : PChar; argp : Pointer) : PChar; cdecl; external LuaLibName; @@ -327,10 +333,10 @@ *) procedure lua_gettable(L : Plua_State ; idx : LongInt); cdecl; external LuaLibName; - + procedure lua_getfield(L : Plua_State; idx : LongInt; k : PChar); cdecl; external LuaLibName; - + procedure lua_rawget(L : Plua_State; idx : LongInt); cdecl; external LuaLibName; @@ -355,10 +361,10 @@ *) procedure lua_settable(L : Plua_State; idx : LongInt); cdecl; external LuaLibName; - + procedure lua_setfield(L : Plua_State; idx : LongInt; const k : PChar); cdecl; external LuaLibName; - + procedure lua_rawset(L : Plua_State; idx : LongInt); cdecl; external LuaLibName; @@ -406,6 +412,7 @@ (* ** garbage-collection functions and options *) + const LUA_GCSTOP = 0; LUA_GCRESTART = 1; @@ -415,7 +422,7 @@ LUA_GCSTEP = 5; LUA_GCSETPAUSE = 6; LUA_GCSETSTEPMUL = 7; - + function lua_gc(L : Plua_State; what, data : LongInt) : LongInt; cdecl; external LuaLibName; diff -r 2286a39140da -r 453917e94e55 hedgewars/Math.h --- a/hedgewars/Math.h Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -#pragma once - diff -r 2286a39140da -r 453917e94e55 hedgewars/SDLMain.h --- a/hedgewars/SDLMain.h Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -/* SDLMain.m - main entry point for our Cocoa-ized SDL app - Initial Version: Darrell Walisser - Non-NIB-Code & other changes: Max Horn - - Feel free to customize this file to suit your needs -*/ - -#ifndef _SDLMain_h_ -#define _SDLMain_h_ - -#import - -@interface SDLMain : NSObject -@end - -#endif /* _SDLMain_h_ */ diff -r 2286a39140da -r 453917e94e55 hedgewars/SDLMain.m --- a/hedgewars/SDLMain.m Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,385 +0,0 @@ -/* SDLMain.m - main entry point for our Cocoa-ized SDL app - Initial Version: Darrell Walisser - Non-NIB-Code & other changes: Max Horn - - Feel free to customize this file to suit your needs -*/ - -#include "SDL.h" -#include "SDLMain.h" -#include /* for MAXPATHLEN */ -#include - -/* For some reaon, Apple removed setAppleMenu from the headers in 10.4, - but the method still is there and works. To avoid warnings, we declare - it ourselves here. */ -@interface NSApplication(SDL_Missing_Methods) -- (void)setAppleMenu:(NSMenu *)menu; -@end - -/* Use this flag to determine whether we use SDLMain.nib or not */ -#define SDL_USE_NIB_FILE 0 - -/* Use this flag to determine whether we use CPS (docking) or not */ -#define SDL_USE_CPS 1 -#ifdef SDL_USE_CPS -/* Portions of CPS.h */ -typedef struct CPSProcessSerNum -{ - UInt32 lo; - UInt32 hi; -} CPSProcessSerNum; - -extern OSErr CPSGetCurrentProcess( CPSProcessSerNum *psn); -extern OSErr CPSEnableForegroundOperation( CPSProcessSerNum *psn, UInt32 _arg2, UInt32 _arg3, UInt32 _arg4, UInt32 _arg5); -extern OSErr CPSSetFrontProcess( CPSProcessSerNum *psn); - -#endif /* SDL_USE_CPS */ - -static int gArgc; -static char **gArgv; -static BOOL gFinderLaunch; -static BOOL gCalledAppMainline = FALSE; - -static NSString *getApplicationName(void) -{ - const NSDictionary *dict; - NSString *appName = 0; - - /* Determine the application name */ - dict = (const NSDictionary *)CFBundleGetInfoDictionary(CFBundleGetMainBundle()); - if (dict) - appName = [dict objectForKey: @"CFBundleName"]; - - if (![appName length]) - appName = [[NSProcessInfo processInfo] processName]; - - return appName; -} - -#if SDL_USE_NIB_FILE -/* A helper category for NSString */ -@interface NSString (ReplaceSubString) -- (NSString *)stringByReplacingRange:(NSRange)aRange with:(NSString *)aString; -@end -#endif - -@interface SDLApplication : NSApplication -@end - -@implementation SDLApplication -/* Invoked from the Quit menu item */ -- (void)terminate:(id)sender -{ - /* Post a SDL_QUIT event */ - SDL_Event event; - event.type = SDL_QUIT; - SDL_PushEvent(&event); -} -@end - -/* The main class of the application, the application's delegate */ -@implementation SDLMain - -/* Set the working directory to the .app's parent directory */ -- (void) setupWorkingDirectory:(BOOL)shouldChdir -{ - if (shouldChdir) - { - char parentdir[MAXPATHLEN]; - CFURLRef url = CFBundleCopyBundleURL(CFBundleGetMainBundle()); - CFURLRef url2 = CFURLCreateCopyDeletingLastPathComponent(0, url); - if (CFURLGetFileSystemRepresentation(url2, 1, (UInt8 *)parentdir, MAXPATHLEN)) { - chdir(parentdir); /* chdir to the binary app's parent */ - } - CFRelease(url); - CFRelease(url2); - } -} - -#if SDL_USE_NIB_FILE - -/* Fix menu to contain the real app name instead of "SDL App" */ -- (void)fixMenu:(NSMenu *)aMenu withAppName:(NSString *)appName -{ - NSRange aRange; - NSEnumerator *enumerator; - NSMenuItem *menuItem; - - aRange = [[aMenu title] rangeOfString:@"SDL App"]; - if (aRange.length != 0) - [aMenu setTitle: [[aMenu title] stringByReplacingRange:aRange with:appName]]; - - enumerator = [[aMenu itemArray] objectEnumerator]; - while ((menuItem = [enumerator nextObject])) - { - aRange = [[menuItem title] rangeOfString:@"SDL App"]; - if (aRange.length != 0) - [menuItem setTitle: [[menuItem title] stringByReplacingRange:aRange with:appName]]; - if ([menuItem hasSubmenu]) - [self fixMenu:[menuItem submenu] withAppName:appName]; - } - [ aMenu sizeToFit ]; -} - -#else - -static void setApplicationMenu(void) -{ - /* warning: this code is very odd */ - NSMenu *appleMenu; - NSMenuItem *menuItem; - NSString *title; - NSString *appName; - - appName = getApplicationName(); - appleMenu = [[NSMenu alloc] initWithTitle:@""]; - - /* Add menu items */ - title = [@"About " stringByAppendingString:appName]; - [appleMenu addItemWithTitle:title action:@selector(orderFrontStandardAboutPanel:) keyEquivalent:@""]; - - [appleMenu addItem:[NSMenuItem separatorItem]]; - - title = [@"Hide " stringByAppendingString:appName]; - [appleMenu addItemWithTitle:title action:@selector(hide:) keyEquivalent:@"h"]; - - menuItem = (NSMenuItem *)[appleMenu addItemWithTitle:@"Hide Others" action:@selector(hideOtherApplications:) keyEquivalent:@"h"]; - [menuItem setKeyEquivalentModifierMask:(NSAlternateKeyMask|NSCommandKeyMask)]; - - [appleMenu addItemWithTitle:@"Show All" action:@selector(unhideAllApplications:) keyEquivalent:@""]; - - [appleMenu addItem:[NSMenuItem separatorItem]]; - - title = [@"Quit " stringByAppendingString:appName]; - [appleMenu addItemWithTitle:title action:@selector(terminate:) keyEquivalent:@"q"]; - - - /* Put menu into the menubar */ - menuItem = [[NSMenuItem alloc] initWithTitle:@"" action:nil keyEquivalent:@""]; - [menuItem setSubmenu:appleMenu]; - [[NSApp mainMenu] addItem:menuItem]; - - /* Tell the application object that this is now the application menu */ - [NSApp setAppleMenu:appleMenu]; - - /* Finally give up our references to the objects */ - [appleMenu release]; - [menuItem release]; -} - -/* Create a window menu */ -static void setupWindowMenu(void) -{ - NSMenu *windowMenu; - NSMenuItem *windowMenuItem; - NSMenuItem *menuItem; - - windowMenu = [[NSMenu alloc] initWithTitle:@"Window"]; - - /* "Minimize" item */ - menuItem = [[NSMenuItem alloc] initWithTitle:@"Minimize" action:@selector(performMiniaturize:) keyEquivalent:@"m"]; - [windowMenu addItem:menuItem]; - [menuItem release]; - - /* Put menu into the menubar */ - windowMenuItem = [[NSMenuItem alloc] initWithTitle:@"Window" action:nil keyEquivalent:@""]; - [windowMenuItem setSubmenu:windowMenu]; - [[NSApp mainMenu] addItem:windowMenuItem]; - - /* Tell the application object that this is now the window menu */ - [NSApp setWindowsMenu:windowMenu]; - - /* Finally give up our references to the objects */ - [windowMenu release]; - [windowMenuItem release]; -} - -/* Replacement for NSApplicationMain */ -static void CustomApplicationMain (int argc, char **argv) -{ - NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; - SDLMain *sdlMain; - - /* Ensure the application object is initialised */ - [SDLApplication sharedApplication]; - -#ifdef SDL_USE_CPS - { - CPSProcessSerNum PSN; - /* Tell the dock about us */ - if (!CPSGetCurrentProcess(&PSN)) - if (!CPSEnableForegroundOperation(&PSN,0x03,0x3C,0x2C,0x1103)) - if (!CPSSetFrontProcess(&PSN)) - [SDLApplication sharedApplication]; - } -#endif /* SDL_USE_CPS */ - - /* Set up the menubar */ - NSMenu *menu = [[NSMenu alloc] init]; - [NSApp setMainMenu:menu]; - setApplicationMenu(); - setupWindowMenu(); - [menu release]; - - /* Create SDLMain and make it the app delegate */ - sdlMain = [[SDLMain alloc] init]; - [NSApp setDelegate:sdlMain]; - - /* Start the main event loop */ - [NSApp run]; - - [sdlMain release]; - [pool release]; -} - -#endif - - -/* - * Catch document open requests...this lets us notice files when the app - * was launched by double-clicking a document, or when a document was - * dragged/dropped on the app's icon. You need to have a - * CFBundleDocumentsType section in your Info.plist to get this message, - * apparently. - * - * Files are added to gArgv, so to the app, they'll look like command line - * arguments. Previously, apps launched from the finder had nothing but - * an argv[0]. - * - * This message may be received multiple times to open several docs on launch. - * - * This message is ignored once the app's mainline has been called. - */ -- (BOOL)application:(NSApplication *)theApplication openFile:(NSString *)filename -{ - const char *temparg; - size_t arglen; - char *arg; - char **newargv; - - if (!gFinderLaunch) /* MacOS is passing command line args. */ - return FALSE; - - if (gCalledAppMainline) /* app has started, ignore this document. */ - return FALSE; - - temparg = [filename UTF8String]; - arglen = SDL_strlen(temparg) + 1; - arg = (char *) SDL_malloc(arglen); - if (arg == NULL) - return FALSE; - - newargv = (char **) realloc(gArgv, sizeof (char *) * (gArgc + 2)); - if (newargv == NULL) - { - SDL_free(arg); - return FALSE; - } - gArgv = newargv; - - SDL_strlcpy(arg, temparg, arglen); - gArgv[gArgc++] = arg; - gArgv[gArgc] = NULL; - return TRUE; -} - - -/* Called when the internal event loop has just started running */ -- (void) applicationDidFinishLaunching: (NSNotification *) note -{ - int status; - - /* Set the working directory to the .app's parent directory */ - [self setupWorkingDirectory:gFinderLaunch]; - -#if SDL_USE_NIB_FILE - /* Set the main menu to contain the real app name instead of "SDL App" */ - [self fixMenu:[NSApp mainMenu] withAppName:getApplicationName()]; -#endif - - /* Hand off to main application code */ - gCalledAppMainline = TRUE; - status = SDL_main (gArgc, gArgv); - - /* We're done, thank you for playing */ - exit(status); -} -@end - - -@implementation NSString (ReplaceSubString) - -- (NSString *)stringByReplacingRange:(NSRange)aRange with:(NSString *)aString -{ - unsigned int bufferSize; - unsigned int selfLen = [self length]; - unsigned int aStringLen = [aString length]; - unichar *buffer; - NSRange localRange; - NSString *result; - - bufferSize = selfLen + aStringLen - aRange.length; - buffer = (unichar *)NSAllocateMemoryPages(bufferSize*sizeof(unichar)); - - /* Get first part into buffer */ - localRange.location = 0; - localRange.length = aRange.location; - [self getCharacters:buffer range:localRange]; - - /* Get middle part into buffer */ - localRange.location = 0; - localRange.length = aStringLen; - [aString getCharacters:(buffer+aRange.location) range:localRange]; - - /* Get last part into buffer */ - localRange.location = aRange.location + aRange.length; - localRange.length = selfLen - localRange.location; - [self getCharacters:(buffer+aRange.location+aStringLen) range:localRange]; - - /* Build output string */ - result = [NSString stringWithCharacters:buffer length:bufferSize]; - - NSDeallocateMemoryPages(buffer, bufferSize); - - return result; -} - -@end - - - -#ifdef main -# undef main -#endif - - -/* Main entry point to executable - should *not* be SDL_main! */ -int main (int argc, char **argv) -{ - /* Copy the arguments into a global variable */ - /* This is passed if we are launched by double-clicking */ - if ( argc >= 2 && strncmp (argv[1], "-psn", 4) == 0 ) { - gArgv = (char **) SDL_malloc(sizeof (char *) * 2); - gArgv[0] = argv[0]; - gArgv[1] = NULL; - gArgc = 1; - gFinderLaunch = YES; - } else { - int i; - gArgc = argc; - gArgv = (char **) SDL_malloc(sizeof (char *) * (argc+1)); - for (i = 0; i <= argc; i++) - gArgv[i] = argv[i]; - gFinderLaunch = NO; - } - -#if SDL_USE_NIB_FILE - [SDLApplication poseAsClass:[NSApplication class]]; - NSApplicationMain (argc, argv); -#else - CustomApplicationMain (argc, argv); -#endif - return 0; -} - diff -r 2286a39140da -r 453917e94e55 hedgewars/SDLh.pas --- a/hedgewars/SDLh.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/SDLh.pas Thu Nov 22 00:41:53 2012 +0100 @@ -244,7 +244,11 @@ SDL_SRCCOLORKEY = $00001000; SDL_RLEACCEL = $00004000; SDL_SRCALPHA = $00010000; + {$IFDEF PAS2C} + SDL_ANYFORMAT = $10000000; + {$ELSE} SDL_ANYFORMAT = $00100000; + {$ENDIF} SDL_HWPALETTE = $20000000; SDL_DOUBLEBUF = $40000000; SDL_FULLSCREEN = $80000000; @@ -387,7 +391,7 @@ {$ENDIF} end; - TSDL_eventaction = (SDL_ADDEVENT, SDL_PEEPEVENT, SDL_GETEVENT); + TSDL_eventaction = (SDL_ADDEVENT, SDL_PEEKEVENT, SDL_GETEVENT); PSDL_Surface = ^TSDL_Surface; TSDL_Surface = record @@ -397,6 +401,16 @@ pitch : {$IFDEF SDL13}LongInt{$ELSE}Word{$ENDIF}; pixels: Pointer; offset: LongInt; +{$IFDEF PAS2C} + hwdata:Pointer; + clip_rect:TSDL_Rect; + unsed1:LongWord; + locked:LongWord; + map:Pointer; + format_version:Longword; + refcount:LongInt; +{$ELSE} + {$IFDEF SDL13} userdata: Pointer; locked: LongInt; @@ -405,6 +419,7 @@ map: Pointer; refcount: LongInt; {$ENDIF} +{$ENDIF} end; @@ -747,6 +762,7 @@ TByteArray = array[0..65535] of Byte; PByteArray = ^TByteArray; + TLongWordArray = array[0..16383] of LongWord; PLongWordArray = ^TLongWordArray; @@ -1109,22 +1125,31 @@ SDL_EnableKeyRepeat:= 0; end; {$ELSE} -const conversionFormat: TSDL_PixelFormat = ( +const convFormat:TSDL_PixelFormat = ( palette: nil; BitsPerPixel: 32; BytesPerPixel: 4; Rloss: 0; Gloss: 0; Bloss: 0; Aloss: 0; Rshift: RShift; Gshift: GShift; Bshift: BShift; Ashift: AShift; + + //TODO: FIXME in pas2c + {$IFDEF WEBGL} + Rmask: RMask; Gmask: GMask; Bmask: BMask; Amask: AMask; + {$ELSE} RMask: RMask; GMask: GMask; BMask: BMask; AMask: AMask; - colorkey: 0; alpha: 255); + colorkey: 0; alpha: 255 + {$ENDIF} + ); function SDL_AllocFormat(format: LongWord): PSDL_PixelFormat; begin format:= format; - SDL_AllocFormat:= @conversionFormat; + SDL_AllocFormat:= @convFormat; end; procedure SDL_FreeFormat(pixelformat: PSDL_PixelFormat); begin + {$IFNDEF PAS2C} pixelformat:= pixelformat; // avoid hint + {$ENDIF} end; {$ENDIF} @@ -1134,7 +1159,7 @@ {$IFDEF SDL13} ((surface^.flags and SDL_RLEACCEL) <> 0) {$ELSE} - ( surface^.offset <> 0 ) or (( surface^.flags and (SDL_HWSURFACE or SDL_ASYNCBLIT or SDL_RLEACCEL)) <> 0) + {$IFNDEF WEBGL}( surface^.offset <> 0 ) or {$ENDIF}(( surface^.flags and (SDL_HWSURFACE or SDL_ASYNCBLIT or SDL_RLEACCEL)) <> 0) {$ENDIF} end; diff -r 2286a39140da -r 453917e94e55 hedgewars/SysUtils.h diff -r 2286a39140da -r 453917e94e55 hedgewars/Types.h diff -r 2286a39140da -r 453917e94e55 hedgewars/VGSHandlers.inc --- a/hedgewars/VGSHandlers.inc Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/VGSHandlers.inc Thu Nov 22 00:41:53 2012 +0100 @@ -197,7 +197,9 @@ //////////////////////////////////////////////////////////////////////////////// procedure doStepLineTrail(Gear: PVisualGear; Steps: Longword); begin +{$IFNDEF PAS2C} Steps := Steps; +{$ENDIF} if Gear^.Timer <= Steps then DeleteVisualGear(Gear) else @@ -464,7 +466,9 @@ b: boolean; t: LongInt; begin +{$IFNDEF PAS2C} Steps:= Steps; // avoid compiler hint +{$ENDIF} for t:= 0 to Pred(TeamsCount) do with thexchar[t] do @@ -532,7 +536,10 @@ procedure doStepSpeechBubble(Gear: PVisualGear; Steps: Longword); begin + +{$IFNDEF PAS2C} Steps:= Steps; // avoid compiler hint +{$ENDIF} with Gear^.Hedgehog^ do if SpeechGear <> nil then diff -r 2286a39140da -r 453917e94e55 hedgewars/adler32.pas --- a/hedgewars/adler32.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/adler32.pas Thu Nov 22 00:41:53 2012 +0100 @@ -2,8 +2,8 @@ {ZLib - Adler32 checksum function} - interface +uses uTypes; (************************************************************************* @@ -66,7 +66,7 @@ Also, the structure was removed to simplify C conversion *) -function Adler32Update ( var adler :longint; Msg :pointer; Len :longint ) : longint; +function Adler32Update (var adler : longint; Msg :Pointer; Len :longint ) : longint; implementation @@ -124,17 +124,19 @@ end; *) -function Adler32Update(var adler: longint; Msg: pointer; Len :longint) : longint; +function Adler32Update(var adler:longint; Msg: Pointer; Len :longint) : longint; {-update Adler32 with Msg data} const BASE = 65521; {max. prime < 65536 } NMAX = 3854; {max. n with 255n(n+1)/2 + (n+1)(BASE-1) < 2^31} var - s1, s2: longint; - i, n: integer; + s1, s2 : longint; + i, n : integer; + m : PByte; begin - s1 := adler and $FFFF; - s2 := adler shr 16; + m := PByte(Msg); + s1 := Longword(adler) and $FFFF; + s2 := Longword(adler) shr 16; while Len>0 do begin if Len - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA - */ - -#include -#include -#include -#include -#include -#include "libavformat/avformat.h" -#include "libavutil/mathematics.h" - -#ifndef AVIO_FLAG_WRITE -#define AVIO_FLAG_WRITE AVIO_WRONLY -#endif - -static AVFormatContext* g_pContainer; -static AVOutputFormat* g_pFormat; -static AVStream* g_pAStream; -static AVStream* g_pVStream; -static AVFrame* g_pAFrame; -static AVFrame* g_pVFrame; -static AVCodec* g_pACodec; -static AVCodec* g_pVCodec; -static AVCodecContext* g_pAudio; -static AVCodecContext* g_pVideo; - -static int g_Width, g_Height; -static uint32_t g_Frequency, g_Channels; -static int g_VQuality; -static AVRational g_Framerate; - -static FILE* g_pSoundFile; -static int16_t* g_pSamples; -static int g_NumSamples; - - -#if LIBAVCODEC_VERSION_MAJOR < 54 -#define OUTBUFFER_SIZE 200000 -static uint8_t g_OutBuffer[OUTBUFFER_SIZE]; -#endif - -// pointer to function from hwengine (uUtils.pas) -static void (*AddFileLogRaw)(const char* pString); - -static void FatalError(const char* pFmt, ...) -{ - char Buffer[1024]; - va_list VaArgs; - - va_start(VaArgs, pFmt); - vsnprintf(Buffer, 1024, pFmt, VaArgs); - va_end(VaArgs); - - AddFileLogRaw("Error in av-wrapper: "); - AddFileLogRaw(Buffer); - AddFileLogRaw("\n"); - exit(1); -} - -// Function to be called from libav for logging. -// Note: libav can call LogCallback from different threads -// (there is mutex in AddFileLogRaw). -static void LogCallback(void* p, int Level, const char* pFmt, va_list VaArgs) -{ - char Buffer[1024]; - - vsnprintf(Buffer, 1024, pFmt, VaArgs); - AddFileLogRaw(Buffer); -} - -static void Log(const char* pFmt, ...) -{ - char Buffer[1024]; - va_list VaArgs; - - va_start(VaArgs, pFmt); - vsnprintf(Buffer, 1024, pFmt, VaArgs); - va_end(VaArgs); - - AddFileLogRaw(Buffer); -} - -static void AddAudioStream() -{ -#if LIBAVFORMAT_VERSION_MAJOR >= 53 - g_pAStream = avformat_new_stream(g_pContainer, g_pACodec); -#else - g_pAStream = av_new_stream(g_pContainer, 1); -#endif - if(!g_pAStream) - { - Log("Could not allocate audio stream\n"); - return; - } - g_pAStream->id = 1; - - g_pAudio = g_pAStream->codec; - - avcodec_get_context_defaults3(g_pAudio, g_pACodec); - g_pAudio->codec_id = g_pACodec->id; - - // put parameters - g_pAudio->sample_fmt = AV_SAMPLE_FMT_S16; - g_pAudio->sample_rate = g_Frequency; - g_pAudio->channels = g_Channels; - - // set quality - g_pAudio->bit_rate = 160000; - - // for codecs that support variable bitrate use it, it should be better - g_pAudio->flags |= CODEC_FLAG_QSCALE; - g_pAudio->global_quality = 1*FF_QP2LAMBDA; - - // some formats want stream headers to be separate - if (g_pFormat->flags & AVFMT_GLOBALHEADER) - g_pAudio->flags |= CODEC_FLAG_GLOBAL_HEADER; - - // open it -#if LIBAVCODEC_VERSION_MAJOR >= 53 - if (avcodec_open2(g_pAudio, g_pACodec, NULL) < 0) -#else - if (avcodec_open(g_pAudio, g_pACodec) < 0) -#endif - { - Log("Could not open audio codec %s\n", g_pACodec->long_name); - return; - } - -#if LIBAVCODEC_VERSION_MAJOR >= 54 - if (g_pACodec->capabilities & CODEC_CAP_VARIABLE_FRAME_SIZE) -#else - if (g_pAudio->frame_size == 0) -#endif - g_NumSamples = 4096; - else - g_NumSamples = g_pAudio->frame_size; - g_pSamples = (int16_t*)av_malloc(g_NumSamples*g_Channels*sizeof(int16_t)); - g_pAFrame = avcodec_alloc_frame(); - if (!g_pAFrame) - { - Log("Could not allocate frame\n"); - return; - } -} - -// returns non-zero if there is more sound -static int WriteAudioFrame() -{ - if (!g_pAStream) - return 0; - - AVPacket Packet = { 0 }; - av_init_packet(&Packet); - - int NumSamples = fread(g_pSamples, 2*g_Channels, g_NumSamples, g_pSoundFile); - -#if LIBAVCODEC_VERSION_MAJOR >= 53 - AVFrame* pFrame = NULL; - if (NumSamples > 0) - { - g_pAFrame->nb_samples = NumSamples; - avcodec_fill_audio_frame(g_pAFrame, g_Channels, AV_SAMPLE_FMT_S16, - (uint8_t*)g_pSamples, NumSamples*2*g_Channels, 1); - pFrame = g_pAFrame; - } - // when NumSamples == 0 we still need to call encode_audio2 to flush - int got_packet; - if (avcodec_encode_audio2(g_pAudio, &Packet, pFrame, &got_packet) != 0) - FatalError("avcodec_encode_audio2 failed"); - if (!got_packet) - return 0; -#else - if (NumSamples == 0) - return 0; - int BufferSize = OUTBUFFER_SIZE; - if (g_pAudio->frame_size == 0) - BufferSize = NumSamples*g_Channels*2; - Packet.size = avcodec_encode_audio(g_pAudio, g_OutBuffer, BufferSize, g_pSamples); - if (Packet.size == 0) - return 1; - if (g_pAudio->coded_frame && g_pAudio->coded_frame->pts != AV_NOPTS_VALUE) - Packet.pts = av_rescale_q(g_pAudio->coded_frame->pts, g_pAudio->time_base, g_pAStream->time_base); - Packet.flags |= AV_PKT_FLAG_KEY; - Packet.data = g_OutBuffer; -#endif - - // Write the compressed frame to the media file. - Packet.stream_index = g_pAStream->index; - if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) - FatalError("Error while writing audio frame"); - return 1; -} - -// add a video output stream -static void AddVideoStream() -{ -#if LIBAVFORMAT_VERSION_MAJOR >= 53 - g_pVStream = avformat_new_stream(g_pContainer, g_pVCodec); -#else - g_pVStream = av_new_stream(g_pContainer, 0); -#endif - if (!g_pVStream) - FatalError("Could not allocate video stream"); - - g_pVideo = g_pVStream->codec; - - avcodec_get_context_defaults3(g_pVideo, g_pVCodec); - g_pVideo->codec_id = g_pVCodec->id; - - // put parameters - // resolution must be a multiple of two - g_pVideo->width = g_Width & ~1; // make even (dimensions should be even) - g_pVideo->height = g_Height & ~1; // make even - /* time base: this is the fundamental unit of time (in seconds) in terms - of which frame timestamps are represented. for fixed-fps content, - timebase should be 1/framerate and timestamp increments should be - identically 1. */ - g_pVideo->time_base.den = g_Framerate.num; - g_pVideo->time_base.num = g_Framerate.den; - //g_pVideo->gop_size = 12; /* emit one intra frame every twelve frames at most */ - g_pVideo->pix_fmt = PIX_FMT_YUV420P; - - // set quality - if (g_VQuality > 100) - g_pVideo->bit_rate = g_VQuality; - else - { - g_pVideo->flags |= CODEC_FLAG_QSCALE; - g_pVideo->global_quality = g_VQuality*FF_QP2LAMBDA; - } - - // some formats want stream headers to be separate - if (g_pFormat->flags & AVFMT_GLOBALHEADER) - g_pVideo->flags |= CODEC_FLAG_GLOBAL_HEADER; - -#if LIBAVCODEC_VERSION_MAJOR < 53 - // for some versions of ffmpeg x264 options must be set explicitly - if (strcmp(g_pVCodec->name, "libx264") == 0) - { - g_pVideo->coder_type = FF_CODER_TYPE_AC; - g_pVideo->flags |= CODEC_FLAG_LOOP_FILTER; - g_pVideo->crf = 23; - g_pVideo->thread_count = 3; - g_pVideo->me_cmp = FF_CMP_CHROMA; - g_pVideo->partitions = X264_PART_I8X8 | X264_PART_I4X4 | X264_PART_P8X8 | X264_PART_B8X8; - g_pVideo->me_method = ME_HEX; - g_pVideo->me_subpel_quality = 7; - g_pVideo->me_range = 16; - g_pVideo->gop_size = 250; - g_pVideo->keyint_min = 25; - g_pVideo->scenechange_threshold = 40; - g_pVideo->i_quant_factor = 0.71; - g_pVideo->b_frame_strategy = 1; - g_pVideo->qcompress = 0.6; - g_pVideo->qmin = 10; - g_pVideo->qmax = 51; - g_pVideo->max_qdiff = 4; - g_pVideo->max_b_frames = 3; - g_pVideo->refs = 3; - g_pVideo->directpred = 1; - g_pVideo->trellis = 1; - g_pVideo->flags2 = CODEC_FLAG2_BPYRAMID | CODEC_FLAG2_MIXED_REFS | CODEC_FLAG2_WPRED | CODEC_FLAG2_8X8DCT | CODEC_FLAG2_FASTPSKIP; - g_pVideo->weighted_p_pred = 2; - } -#endif - - // open the codec -#if LIBAVCODEC_VERSION_MAJOR >= 53 - AVDictionary* pDict = NULL; - if (strcmp(g_pVCodec->name, "libx264") == 0) - av_dict_set(&pDict, "preset", "medium", 0); - - if (avcodec_open2(g_pVideo, g_pVCodec, &pDict) < 0) -#else - if (avcodec_open(g_pVideo, g_pVCodec) < 0) -#endif - FatalError("Could not open video codec %s", g_pVCodec->long_name); - - g_pVFrame = avcodec_alloc_frame(); - if (!g_pVFrame) - FatalError("Could not allocate frame"); - - g_pVFrame->linesize[0] = g_Width; - g_pVFrame->linesize[1] = g_Width/2; - g_pVFrame->linesize[2] = g_Width/2; - g_pVFrame->linesize[3] = 0; -} - -static int WriteFrame(AVFrame* pFrame) -{ - double AudioTime, VideoTime; - - // write interleaved audio frame - if (g_pAStream) - { - VideoTime = (double)g_pVStream->pts.val*g_pVStream->time_base.num/g_pVStream->time_base.den; - do - AudioTime = (double)g_pAStream->pts.val*g_pAStream->time_base.num/g_pAStream->time_base.den; - while (AudioTime < VideoTime && WriteAudioFrame()); - } - - if (!g_pVStream) - return 0; - - AVPacket Packet; - av_init_packet(&Packet); - Packet.data = NULL; - Packet.size = 0; - - g_pVFrame->pts++; - if (g_pFormat->flags & AVFMT_RAWPICTURE) - { - /* raw video case. The API will change slightly in the near - future for that. */ - Packet.flags |= AV_PKT_FLAG_KEY; - Packet.stream_index = g_pVStream->index; - Packet.data = (uint8_t*)pFrame; - Packet.size = sizeof(AVPicture); - - if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) - FatalError("Error while writing video frame"); - return 0; - } - else - { -#if LIBAVCODEC_VERSION_MAJOR >= 54 - int got_packet; - if (avcodec_encode_video2(g_pVideo, &Packet, pFrame, &got_packet) < 0) - FatalError("avcodec_encode_video2 failed"); - if (!got_packet) - return 0; - - if (Packet.pts != AV_NOPTS_VALUE) - Packet.pts = av_rescale_q(Packet.pts, g_pVideo->time_base, g_pVStream->time_base); - if (Packet.dts != AV_NOPTS_VALUE) - Packet.dts = av_rescale_q(Packet.dts, g_pVideo->time_base, g_pVStream->time_base); -#else - Packet.size = avcodec_encode_video(g_pVideo, g_OutBuffer, OUTBUFFER_SIZE, pFrame); - if (Packet.size < 0) - FatalError("avcodec_encode_video failed"); - if (Packet.size == 0) - return 0; - - if( g_pVideo->coded_frame->pts != AV_NOPTS_VALUE) - Packet.pts = av_rescale_q(g_pVideo->coded_frame->pts, g_pVideo->time_base, g_pVStream->time_base); - if( g_pVideo->coded_frame->key_frame ) - Packet.flags |= AV_PKT_FLAG_KEY; - Packet.data = g_OutBuffer; -#endif - // write the compressed frame in the media file - Packet.stream_index = g_pVStream->index; - if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) - FatalError("Error while writing video frame"); - - return 1; - } -} - -void AVWrapper_WriteFrame(uint8_t* pY, uint8_t* pCb, uint8_t* pCr) -{ - g_pVFrame->data[0] = pY; - g_pVFrame->data[1] = pCb; - g_pVFrame->data[2] = pCr; - WriteFrame(g_pVFrame); -} - -void AVWrapper_Init( - void (*pAddFileLogRaw)(const char*), - const char* pFilename, - const char* pDesc, - const char* pSoundFile, - const char* pFormatName, - const char* pVCodecName, - const char* pACodecName, - int Width, int Height, - int FramerateNum, int FramerateDen, - int VQuality) -{ - AddFileLogRaw = pAddFileLogRaw; - av_log_set_callback( &LogCallback ); - - g_Width = Width; - g_Height = Height; - g_Framerate.num = FramerateNum; - g_Framerate.den = FramerateDen; - g_VQuality = VQuality; - - // initialize libav and register all codecs and formats - av_register_all(); - - // find format - g_pFormat = av_guess_format(pFormatName, NULL, NULL); - if (!g_pFormat) - FatalError("Format \"%s\" was not found", pFormatName); - - // allocate the output media context - g_pContainer = avformat_alloc_context(); - if (!g_pContainer) - FatalError("Could not allocate output context"); - - g_pContainer->oformat = g_pFormat; - - // store description of file - av_dict_set(&g_pContainer->metadata, "comment", pDesc, 0); - - // append extesnion to filename - char ext[16]; - strncpy(ext, g_pFormat->extensions, 16); - ext[15] = 0; - ext[strcspn(ext,",")] = 0; - snprintf(g_pContainer->filename, sizeof(g_pContainer->filename), "%s.%s", pFilename, ext); - - // find codecs - g_pVCodec = avcodec_find_encoder_by_name(pVCodecName); - g_pACodec = avcodec_find_encoder_by_name(pACodecName); - - // add audio and video stream to container - g_pVStream = NULL; - g_pAStream = NULL; - - if (g_pVCodec) - AddVideoStream(); - else - Log("Video codec \"%s\" was not found; video will be ignored.\n", pVCodecName); - - if (g_pACodec) - { - g_pSoundFile = fopen(pSoundFile, "rb"); - if (g_pSoundFile) - { - fread(&g_Frequency, 4, 1, g_pSoundFile); - fread(&g_Channels, 4, 1, g_pSoundFile); - AddAudioStream(); - } - else - Log("Could not open %s\n", pSoundFile); - } - else - Log("Audio codec \"%s\" was not found; audio will be ignored.\n", pACodecName); - - if (!g_pAStream && !g_pVStream) - FatalError("No video, no audio, aborting..."); - - // write format info to log - av_dump_format(g_pContainer, 0, g_pContainer->filename, 1); - - // open the output file, if needed - if (!(g_pFormat->flags & AVFMT_NOFILE)) - { - if (avio_open(&g_pContainer->pb, g_pContainer->filename, AVIO_FLAG_WRITE) < 0) - FatalError("Could not open output file (%s)", g_pContainer->filename); - } - - // write the stream header, if any - avformat_write_header(g_pContainer, NULL); - - g_pVFrame->pts = -1; -} - -void AVWrapper_Close() -{ - // output buffered frames - if (g_pVCodec->capabilities & CODEC_CAP_DELAY) - while( WriteFrame(NULL) ); - // output any remaining audio - while( WriteAudioFrame() ); - - // write the trailer, if any. - av_write_trailer(g_pContainer); - - // close the output file - if (!(g_pFormat->flags & AVFMT_NOFILE)) - avio_close(g_pContainer->pb); - - // free everything - if (g_pVStream) - { - avcodec_close(g_pVideo); - av_free(g_pVideo); - av_free(g_pVStream); - av_free(g_pVFrame); - } - if (g_pAStream) - { - avcodec_close(g_pAudio); - av_free(g_pAudio); - av_free(g_pAStream); - av_free(g_pAFrame); - av_free(g_pSamples); - fclose(g_pSoundFile); - } - - av_free(g_pContainer); -} diff -r 2286a39140da -r 453917e94e55 hedgewars/hwengine.ico Binary file hedgewars/hwengine.ico has changed diff -r 2286a39140da -r 453917e94e55 hedgewars/hwengine.pas --- a/hedgewars/hwengine.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/hwengine.pas Thu Nov 22 00:41:53 2012 +0100 @@ -29,16 +29,16 @@ program hwengine; {$ENDIF} -uses SDLh, uMisc, uConsole, uGame, uConsts, uLand, uAmmos, uVisualGears, uGears, uStore, uWorld, uInputHandler - , uSound, uScript, uTeams, uStats, uIO, uLocale, uChat, uAI, uAIMisc, uAILandMarks, uLandTexture, uCollisions - , SysUtils, uTypes, uVariables, uCommands, uUtils, uCaptions, uDebug, uCommandHandlers, uLandPainted - , uPhysFSLayer +uses SDLh, uMisc, uConsole, uGame, uConsts, uLand, uAmmos, uVisualGears, uGears, uStore, uWorld, uInputHandler, + uSound, uScript, uTeams, uStats, uIO, uLocale, uChat, uAI, uAIMisc, uLandTexture, uCollisions, + uAILandMarks, SysUtils, uTypes, uVariables, uCommands, uUtils, uCaptions, uDebug, uCommandHandlers, + uLandPainted, uFloat, uPhysFSLayer {$IFDEF USE_VIDEO_RECORDING}, uVideoRec {$ENDIF} {$IFDEF USE_TOUCH_INTERFACE}, uTouch {$ENDIF} {$IFDEF ANDROID}, GLUnit{$ENDIF} + {$IFDEF WEBGL}, uWeb{$ENDIF} ; - {$IFDEF HWLIBRARY} procedure preInitEverything(); procedure initEverything(complete:boolean); @@ -53,6 +53,20 @@ procedure freeEverything(complete:boolean); forward; {$ENDIF} +{$IFDEF WEBGL} +procedure playFile(path: PChar); forward; +function isEngineRunning():Integer; forward; +procedure shutdown();forward; +function getRealTicks():Integer; forward; +procedure mainhook(); forward; +var + args: array[0..3] of PChar; + PrevTime, CurrTime: LongInt; + isTerminated: boolean; + prevFocusState: boolean; + isRunning : boolean; +{$ENDIF} + /////////////////////////////////////////////////////////////////////////////// function DoTimer(Lag: LongInt): boolean; var s: shortstring; @@ -91,7 +105,13 @@ end; gsConfirm, gsGame: begin - if not cOnlyStats then DrawWorld(Lag); + if not cOnlyStats then +{$IFDEF WEBGL} + drawworld_hook(); +{$ELSE} + // never place between ProcessKbd and DoGameTick - bugs due to /put cmd and isCursorVisible + DrawWorld(Lag); +{$ENDIF} DoGameTick(Lag); if not cOnlyStats then ProcessVisualGears(Lag); end; @@ -144,18 +164,26 @@ /////////////////////////////////////////////////////////////////////////////// procedure MainLoop; var event: TSDL_Event; - PrevTime, CurrTime: Longword; +{$IFNDEF WEBGL} + PrevTime, CurrTime: LongInt; isTerminated: boolean; {$IFDEF SDL13} previousGameState: TGameState; {$ELSE} prevFocusState: boolean; {$ENDIF} + +{$ENDIF} + begin + +{$IFNDEF WEBGL} isTerminated:= false; PrevTime:= SDL_GetTicks; while isTerminated = false do begin +{$ENDIF} + SDL_PumpEvents(); while SDL_PeepEvents(@event, 1, SDL_GETEVENT, {$IFDEF SDL13}SDL_FIRSTEVENT, SDL_LASTEVENT{$ELSE}SDL_ALLEVENTS{$ENDIF}) > 0 do @@ -272,12 +300,24 @@ CurrTime:= SDL_GetTicks(); if PrevTime + longword(cTimerInterval) <= CurrTime then begin - isTerminated := isTerminated or DoTimer(CurrTime - PrevTime); - PrevTime:= CurrTime + isTerminated:= isTerminated or DoTimer(CurrTime - PrevTime); + PrevTime:= CurrTime; + {$IFDEF WEBGL} + if not isTerminated then + mainloop_hook(); + else + begin + freeEverything(true); + isRunning := false; + end + {$ENDIF} end - else SDL_Delay(1); + else {$IFNDEF WEBGL}SDL_Delay(1){$ELSE}mainloop_hook(){$ENDIF}; IPCCheckSock(); + +{$IFNDEF WEBGL} end; +{$ENDIF} end; {$IFDEF USE_VIDEO_RECORDING} @@ -318,6 +358,10 @@ var p: TPathType; s: shortstring; i: LongInt; +{$IFDEF WEBGL} + l:TResourceList; +{$ENDIF} + begin {$IFDEF HWLIBRARY} preInitEverything(); @@ -338,8 +382,6 @@ initEverything(true); WriteLnToConsole('Hedgewars ' + cVersionString + ' engine (network protocol: ' + inttostr(cNetProtoVersion) + ')'); - AddFileLog('Prefix: "' + PathPrefix +'"'); - AddFileLog('UserPrefix: "' + UserPathPrefix +'"'); for i:= 0 to ParamCount do AddFileLog(inttostr(i) + ': ' + ParamStr(i)); @@ -412,13 +454,27 @@ {$IFDEF USE_VIDEO_RECORDING} if GameType = gmtRecord then - RecorderMainLoop() - else + begin + RecorderMainLoop(); + freeEverything(true); + exit; + end; {$ENDIF} - MainLoop(); - + +{$IFDEF WEBGL} + l := generateResourceList(); + clear_filelist_hook(); + for i:= 0 to l.count - 1 do + add_file_hook(PChar(l.files[i] + '.png')); + isTerminated := false; + isRunning := true; + PrevTime := SDL_GetTicks(); + idb_loader_hook(); +{$ELSE} + MainLoop; // clean up all the memory allocated freeEverything(true); +{$ENDIF} end; /////////////////////////////////////////////////////////////////////////////// @@ -594,7 +650,18 @@ /////////////////////////////////////////////////////////////////////////////// /////////////////////////////////// m a i n /////////////////////////////////// /////////////////////////////////////////////////////////////////////////////// +{$IFDEF WEBGL} +procedure hwmain(argc:Integer; argv:PPChar); +{$ENDIF} begin +{$IFDEF PAS2C} + // workaround for pascal's ParamStr and ParamCount + init(argc, argv); +{$IFDEF WEBGL} + // patch emscripten's SDL implementation + SDL_InitPatch(); +{$ENDIF} +{$ENDIF} preInitEverything(); GetParams(); @@ -605,6 +672,62 @@ else Game(); // return 1 when engine is not called correctly - halt(LongInt(GameType = gmtSyntax)); + {$IFDEF PAS2C} + {$IFNDEF WEBGL} + exit(LongInt(GameType = gmtSyntax)); + {$ENDIF} + {$ELSE} + halt(LongInt(GameType = gmtSyntax)); + {$ENDIF} + + +{$IFDEF WEBGL} +end; + +// hook +procedure playFile(path: PChar); +begin + args[0] := PChar(''); + args[1] := PChar(''); + args[2] := PChar('Data'); + args[3] := path; + hwmain(4, args); +end; + +// hook +function isEngineRunning:Integer; +begin + isEngineRunning := isRunning; +end; + +// hook +procedure shutdown; +begin + GameState := gsExit; +end; + +// hook +function getRealTicks():Integer; +begin + getRealTicks := RealTicks; +end; + +// main +begin + isRunning := false; + + // avoid hooks to be eliminated by optimizer + if argc = 1234 then + begin + mainhook(); + isRunning := isEngineRunning(); + playFile(argv); + argc := getRealTicks(); + DrawWorld(argc); + MainLoop; + shutdown; + end +{$ENDIF} + {$ENDIF} end. diff -r 2286a39140da -r 453917e94e55 hedgewars/hwengine.rc --- a/hedgewars/hwengine.rc Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -MAINICON ICON "hwengine.ico" \ No newline at end of file diff -r 2286a39140da -r 453917e94e55 hedgewars/options.inc --- a/hedgewars/options.inc Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/options.inc Thu Nov 22 00:41:53 2012 +0100 @@ -29,6 +29,13 @@ {$DEFINE USE_LUA_SCRIPT} +{$IF DEFINED(WEBGL) AND NOT DEFINED(PAS2C)} +{$UNDEF WEBGL} +{$ENDIF} + +{$IFDEF WEBGL} +{$DEFINE GL2} +{$ENDIF} {$IFDEF ANDROID} {$DEFINE MOBILE} diff -r 2286a39140da -r 453917e94e55 hedgewars/pas2c.h --- a/hedgewars/pas2c.h Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,144 +0,0 @@ -#pragma once - -#include -#include -#include -#include - -typedef union string255_ - { - struct { - char s[256]; - }; - struct { - char len; - char str[255]; - }; - } string255; -typedef struct string192_ - { - char s[193]; - } string192; -typedef struct string31_ - { - char s[32]; - } string31; -typedef struct string15_ - { - char s[16]; - } string15; - -typedef string255 shortstring; -typedef string255 ansistring; - -typedef uint8_t Byte; -typedef int8_t ShortInt; -typedef uint16_t Word; -typedef int16_t SmallInt; -typedef uint32_t LongWord; -typedef int32_t LongInt; -typedef uint64_t QWord; -typedef int64_t Int64; -typedef LongWord Cardinal; - -typedef LongInt Integer; -typedef float extended; -typedef float real; -typedef float single; - -typedef bool boolean; -typedef int LongBool; - -typedef void * pointer; -typedef Byte * PByte; -typedef char * PChar; -typedef LongInt * PLongInt; -typedef LongWord * PLongWord; -typedef Integer * PInteger; -typedef int PtrInt; -typedef wchar_t widechar; - -#define new(a) __new((void **)&a, sizeof(*(a))) -void __new(void ** p, int size); -#define dispose(a) __dispose(a, sizeof(*(a))) -void __dispose(pointer p, int size); - -void * GetMem(int size); -void FreeMem(void * p, int size); - -#define FillChar(a, b, c) __FillChar(&(a), b, c) - -void __FillChar(pointer p, int size, char fill); -string255 _strconcat(string255 a, string255 b); -string255 _strappend(string255 s, char c); -string255 _strprepend(char c, string255 s); -string255 _chrconcat(char a, char b); -bool _strcompare(string255 a, string255 b); -bool _strcomparec(string255 a, char b); -bool _strncompare(string255 a, string255 b); -char * _pchar(string255 s); -string255 pchar2str(char * s); - -int Length(string255 a); -string255 copy(string255 a, int s, int l); -string255 delete(string255 a, int s, int l); -string255 trim(string255 a); - -#define STRINIT(a) {.len = sizeof(a) - 1, .str = a} - - -int length_ar(void * a); - -typedef int file; -typedef int TextFile; -extern int FileMode; -extern int IOResult; -extern int stdout; -extern int stderr; - -#define assign(a, b) assign_(&(a), b) -void assign_(int * f, string255 fileName); -void reset_1(int f, int size); -void reset_2(int f, int size); -#define BlockRead(a, b, c, d) BlockRead_(a, &(b), c, &(d)) -void BlockRead_(int f, void * p, int size, int * sizeRead); -#define BlockWrite(a, b, c) BlockWrite_(a, &(b), c) -void BlockWrite_(int f, void * p, int size); -void close(int f); - -void write(int f, string255 s); -void writeLn(int f, string255 s); - -bool DirectoryExists(string255 dir); -bool FileExists(string255 filename); - -bool odd(int i); - - -typedef int TThreadId; -void ThreadSwitch(); -#define InterlockedIncrement(a) __InterlockedIncrement(&(a)) -#define InterlockedDecrement(a) __InterlockedDecrement(&(a)) -void __InterlockedIncrement(int * a); -void __InterlockedDecrement(int * a); - -bool Assigned(void * a); - -void randomize(); -int random(int max); -int abs(int i); -double sqr(double n); -double sqrt(double n); -int trunc(double n); -int round(double n); - -string255 ParamStr(int n); -int ParamCount(); - -#define val(a, b, c) _val(a, (LongInt*)&(b), (LongInt*)&(c)) -void _val(string255 str, LongInt * a, LongInt * c); - -extern double pi; - -string255 EnumToStr(int a); -string255 ExtractFileName(string255 f); diff -r 2286a39140da -r 453917e94e55 hedgewars/pas2cRedo.pas --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/pas2cRedo.pas Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,111 @@ +redo; +{This file contains functions that are re-implemented} +{pas2c will add prefix fpcrtl_ to all these functions} +type + uinteger = uinteger; + Integer = integer; + LongInt = integer; + LongWord = uinteger; + Cardinal = uinteger; + PtrInt = integer; + Word = uinteger; + Byte = integer; + SmallInt = integer; + ShortInt = integer; + QWord = uinteger; + GLint = integer; + GLuint = integer; + int = integer; + size_t = integer; + + pointer = pointer; + + float = float; + single = float; + double = float; + real = float; + extended = float; + GLfloat = float; + + boolean = boolean; + LongBool = boolean; + + string = string; + shortstring = string; + ansistring = string; + widechar = string; + + char = char; + PChar = ^char; + PPChar = ^Pchar; + + PByte = ^Byte; + PLongInt = ^LongInt; + PLongWord = ^LongWord; + PInteger = ^Integer; + + Handle = integer; + +var + write, writeLn, read, readLn, flush: procedure; + + halt:procedure; + + GetEnumName:function:shortstring; + TypeInfo:function:Integer; + + lo:function:Integer; + + init:procedure; + + StrLen:function : integer; + odd, even : function : boolean; + + Length : function : integer; + + Now : function : integer; + + new, dispose, FillChar, Move : procedure; + + trunc, round : function : integer; + abs, sqr : function : integer; + + StrPas, FormatDateTime, copy, delete, str, pos, PosS, trim, LowerCase : function : shortstring; + StrToInt : function : integer; + SetLength, val : procedure; + _pchar : function : PChar; + pchar2str : function : string; + memcpy : procedure; + + min, max:function:integer; + assign, rewrite, rewrite_2, reset, reset_2, flush, BlockWrite, BlockRead, close : procedure; + FileExists, DirectoryExists, eof : function : boolean; + ExtractFileName : function : string; + + ParamCount : function : integer; + ParamStr : function : string; + + arctan2, power: function : float; + + //TypeInfo, GetEnumName : function : shortstring; + + UTF8ToUnicode, WrapText: function : shortstring; + + GetMem : function : pointer; + FreeMem : procedure; + + BeginThread, ThreadSwitch : procedure; + InterlockedIncrement, InterlockedDecrement : procedure; + + random : function : integer; + randomize : procedure; + + Assigned : function : boolean; + + //EnumToStr : function : string; + + initParams : procedure; + + Load_GL_VERSION_2_0 : procedure; + + diff -r 2286a39140da -r 453917e94e55 hedgewars/pas2cSystem.pas --- a/hedgewars/pas2cSystem.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/pas2cSystem.pas Thu Nov 22 00:41:53 2012 +0100 @@ -1,18 +1,21 @@ system; type + uinteger = uinteger; Integer = integer; LongInt = integer; - LongWord = integer; - Cardinal = integer; + LongWord = uinteger; + Cardinal = uinteger; PtrInt = integer; - Word = integer; + Word = uinteger; Byte = integer; SmallInt = integer; ShortInt = integer; - QWord = integer; + QWord = uinteger; GLint = integer; GLuint = integer; + GLenum = integer; + int = integer; size_t = integer; @@ -51,51 +54,22 @@ var false, true: boolean; - write, writeLn, read, readLn: procedure; - - StrLen, ord, Succ, Pred : function : integer; + ord, Succ, Pred : function : integer; inc, dec, Low, High, Lo, Hi : function : integer; - odd, even : function : boolean; - - Now : function : integer; - - new, dispose, FillChar, Move : procedure; - trunc, round : function : integer; - abs, sqr : function : integer; - - StrPas, FormatDateTime, copy, delete, str, pos, trim, LowerCase : function : shortstring; - Length, StrToInt : function : integer; - SetLength, val : procedure; - _pchar : function : PChar; - pchar2str : function : string; - memcpy : procedure; - - assign, rewrite, reset, flush, BlockWrite, BlockRead, close : procedure; IOResult : integer; exit, break, halt, continue : procedure; - TextFile, file : Handle; + + TextFile, File : Handle; FileMode : integer; - FileExists, DirectoryExists, eof : function : boolean; - ExtractFileName : function : string; exitcode : integer; stdout, stderr : Handle; - - ParamCount : function : integer; - ParamStr : function : string; - sqrt, arctan2, cos, sin, power : function : float; + sqrt, cos, sin: function : float; pi : float; - TypeInfo, GetEnumName : function : shortstring; - - UTF8ToUnicode, WrapText: function : shortstring; - sizeof : function : integer; - GetMem : function : pointer; - FreeMem : procedure; - glGetString : function : pchar; glBegin, glBindTexture, glBlendFunc, glClear, glClearColor, @@ -110,7 +84,15 @@ glDeleteFramebuffersEXT, glGenFramebuffersEXT, glGenRenderbuffersEXT, glBindFramebufferEXT, glBindRenderbufferEXT, glRenderbufferStorageEXT, - glFramebufferRenderbufferEXT, glFramebufferTexture2DEXT : procedure; + glFramebufferRenderbufferEXT, glFramebufferTexture2DEXT, + glUniformMatrix4fv, glVertexAttribPointer, glCreateShader, + glShaderSource, glCompileShader, glGetShaderiv, glGetShaderInfoLog, + glCreateProgram, glAttachShader, glBindAttribLocation, glLinkProgram, + glDeleteShader, glGetProgramiv, glGetProgramInfoLog, glUseProgram, + glUniform1i, glGetUniformLocation, glEnableVertexAttribArray, + glGetError, glDeleteProgram, glDeleteBuffers, + glGenBuffers, glBufferData, glBindBuffer, glewInit, + glUniform4f, glDisableVertexAttribArray : procedure; GL_BGRA, GL_BLEND, GL_CLAMP_TO_EDGE, GL_COLOR_ARRAY, GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT, GL_DEPTH_COMPONENT, @@ -124,16 +106,12 @@ GL_TEXTURE_WRAP_T, GL_TRIANGLE_FAN, GL_TRUE, GL_VENDOR, GL_VERSION, GL_VERTEX_ARRAY, GLenum, GL_FRAMEBUFFER_EXT, GL_RENDERBUFFER_EXT, GL_DEPTH_ATTACHMENT_EXT, - GL_COLOR_ATTACHMENT0_EXT, GL_FLOAT, GL_UNSIGNED_BYTE : integer; + GL_COLOR_ATTACHMENT0_EXT, GL_FLOAT, GL_UNSIGNED_BYTE, GL_COMPILE_STATUS, + GL_INFO_LOG_LENGTH, GL_LINK_STATUS, GL_VERTEX_SHADER, GL_FRAGMENT_SHADER, + GL_NO_ERROR, GL_ARRAY_BUFFER, GL_STATIC_DRAW, GLEW_OK, + GL_AUX_BUFFERS: integer; TThreadId : function : integer; - BeginThread, ThreadSwitch : procedure; - InterlockedIncrement, InterlockedDecrement : procedure; - - random : function : integer; - randomize : procedure; - - Assigned : function : boolean; _strconcat, _strappend, _strprepend, _chrconcat : function : string; _strcompare, _strncompare, _strcomparec : function : boolean; @@ -144,5 +122,7 @@ png_write_row, png_set_ihdr, png_write_info, png_write_end : procedure; - EnumToStr : function : string; + clear_filelist_hook, add_file_hook, idb_loader_hook, mainloop_hook, drawworld_hook : procedure; + SDL_InitPatch : procedure; + diff -r 2286a39140da -r 453917e94e55 hedgewars/res/hwengine.ico Binary file hedgewars/res/hwengine.ico has changed diff -r 2286a39140da -r 453917e94e55 hedgewars/res/hwengine.rc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/res/hwengine.rc Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,1 @@ +MAINICON ICON "res/hwengine.ico" \ No newline at end of file diff -r 2286a39140da -r 453917e94e55 hedgewars/sdlmain_osx/SDLMain.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/sdlmain_osx/SDLMain.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,16 @@ +/* SDLMain.m - main entry point for our Cocoa-ized SDL app + Initial Version: Darrell Walisser + Non-NIB-Code & other changes: Max Horn + + Feel free to customize this file to suit your needs +*/ + +#ifndef _SDLMain_h_ +#define _SDLMain_h_ + +#import + +@interface SDLMain : NSObject +@end + +#endif /* _SDLMain_h_ */ diff -r 2286a39140da -r 453917e94e55 hedgewars/sdlmain_osx/SDLMain.m --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/sdlmain_osx/SDLMain.m Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,385 @@ +/* SDLMain.m - main entry point for our Cocoa-ized SDL app + Initial Version: Darrell Walisser + Non-NIB-Code & other changes: Max Horn + + Feel free to customize this file to suit your needs +*/ + +#include "SDL.h" +#include "SDLMain.h" +#include /* for MAXPATHLEN */ +#include + +/* For some reaon, Apple removed setAppleMenu from the headers in 10.4, + but the method still is there and works. To avoid warnings, we declare + it ourselves here. */ +@interface NSApplication(SDL_Missing_Methods) +- (void)setAppleMenu:(NSMenu *)menu; +@end + +/* Use this flag to determine whether we use SDLMain.nib or not */ +#define SDL_USE_NIB_FILE 0 + +/* Use this flag to determine whether we use CPS (docking) or not */ +#define SDL_USE_CPS 1 +#ifdef SDL_USE_CPS +/* Portions of CPS.h */ +typedef struct CPSProcessSerNum +{ + UInt32 lo; + UInt32 hi; +} CPSProcessSerNum; + +extern OSErr CPSGetCurrentProcess( CPSProcessSerNum *psn); +extern OSErr CPSEnableForegroundOperation( CPSProcessSerNum *psn, UInt32 _arg2, UInt32 _arg3, UInt32 _arg4, UInt32 _arg5); +extern OSErr CPSSetFrontProcess( CPSProcessSerNum *psn); + +#endif /* SDL_USE_CPS */ + +static int gArgc; +static char **gArgv; +static BOOL gFinderLaunch; +static BOOL gCalledAppMainline = FALSE; + +static NSString *getApplicationName(void) +{ + const NSDictionary *dict; + NSString *appName = 0; + + /* Determine the application name */ + dict = (const NSDictionary *)CFBundleGetInfoDictionary(CFBundleGetMainBundle()); + if (dict) + appName = [dict objectForKey: @"CFBundleName"]; + + if (![appName length]) + appName = [[NSProcessInfo processInfo] processName]; + + return appName; +} + +#if SDL_USE_NIB_FILE +/* A helper category for NSString */ +@interface NSString (ReplaceSubString) +- (NSString *)stringByReplacingRange:(NSRange)aRange with:(NSString *)aString; +@end +#endif + +@interface SDLApplication : NSApplication +@end + +@implementation SDLApplication +/* Invoked from the Quit menu item */ +- (void)terminate:(id)sender +{ + /* Post a SDL_QUIT event */ + SDL_Event event; + event.type = SDL_QUIT; + SDL_PushEvent(&event); +} +@end + +/* The main class of the application, the application's delegate */ +@implementation SDLMain + +/* Set the working directory to the .app's parent directory */ +- (void) setupWorkingDirectory:(BOOL)shouldChdir +{ + if (shouldChdir) + { + char parentdir[MAXPATHLEN]; + CFURLRef url = CFBundleCopyBundleURL(CFBundleGetMainBundle()); + CFURLRef url2 = CFURLCreateCopyDeletingLastPathComponent(0, url); + if (CFURLGetFileSystemRepresentation(url2, 1, (UInt8 *)parentdir, MAXPATHLEN)) { + chdir(parentdir); /* chdir to the binary app's parent */ + } + CFRelease(url); + CFRelease(url2); + } +} + +#if SDL_USE_NIB_FILE + +/* Fix menu to contain the real app name instead of "SDL App" */ +- (void)fixMenu:(NSMenu *)aMenu withAppName:(NSString *)appName +{ + NSRange aRange; + NSEnumerator *enumerator; + NSMenuItem *menuItem; + + aRange = [[aMenu title] rangeOfString:@"SDL App"]; + if (aRange.length != 0) + [aMenu setTitle: [[aMenu title] stringByReplacingRange:aRange with:appName]]; + + enumerator = [[aMenu itemArray] objectEnumerator]; + while ((menuItem = [enumerator nextObject])) + { + aRange = [[menuItem title] rangeOfString:@"SDL App"]; + if (aRange.length != 0) + [menuItem setTitle: [[menuItem title] stringByReplacingRange:aRange with:appName]]; + if ([menuItem hasSubmenu]) + [self fixMenu:[menuItem submenu] withAppName:appName]; + } + [ aMenu sizeToFit ]; +} + +#else + +static void setApplicationMenu(void) +{ + /* warning: this code is very odd */ + NSMenu *appleMenu; + NSMenuItem *menuItem; + NSString *title; + NSString *appName; + + appName = getApplicationName(); + appleMenu = [[NSMenu alloc] initWithTitle:@""]; + + /* Add menu items */ + title = [@"About " stringByAppendingString:appName]; + [appleMenu addItemWithTitle:title action:@selector(orderFrontStandardAboutPanel:) keyEquivalent:@""]; + + [appleMenu addItem:[NSMenuItem separatorItem]]; + + title = [@"Hide " stringByAppendingString:appName]; + [appleMenu addItemWithTitle:title action:@selector(hide:) keyEquivalent:@"h"]; + + menuItem = (NSMenuItem *)[appleMenu addItemWithTitle:@"Hide Others" action:@selector(hideOtherApplications:) keyEquivalent:@"h"]; + [menuItem setKeyEquivalentModifierMask:(NSAlternateKeyMask|NSCommandKeyMask)]; + + [appleMenu addItemWithTitle:@"Show All" action:@selector(unhideAllApplications:) keyEquivalent:@""]; + + [appleMenu addItem:[NSMenuItem separatorItem]]; + + title = [@"Quit " stringByAppendingString:appName]; + [appleMenu addItemWithTitle:title action:@selector(terminate:) keyEquivalent:@"q"]; + + + /* Put menu into the menubar */ + menuItem = [[NSMenuItem alloc] initWithTitle:@"" action:nil keyEquivalent:@""]; + [menuItem setSubmenu:appleMenu]; + [[NSApp mainMenu] addItem:menuItem]; + + /* Tell the application object that this is now the application menu */ + [NSApp setAppleMenu:appleMenu]; + + /* Finally give up our references to the objects */ + [appleMenu release]; + [menuItem release]; +} + +/* Create a window menu */ +static void setupWindowMenu(void) +{ + NSMenu *windowMenu; + NSMenuItem *windowMenuItem; + NSMenuItem *menuItem; + + windowMenu = [[NSMenu alloc] initWithTitle:@"Window"]; + + /* "Minimize" item */ + menuItem = [[NSMenuItem alloc] initWithTitle:@"Minimize" action:@selector(performMiniaturize:) keyEquivalent:@"m"]; + [windowMenu addItem:menuItem]; + [menuItem release]; + + /* Put menu into the menubar */ + windowMenuItem = [[NSMenuItem alloc] initWithTitle:@"Window" action:nil keyEquivalent:@""]; + [windowMenuItem setSubmenu:windowMenu]; + [[NSApp mainMenu] addItem:windowMenuItem]; + + /* Tell the application object that this is now the window menu */ + [NSApp setWindowsMenu:windowMenu]; + + /* Finally give up our references to the objects */ + [windowMenu release]; + [windowMenuItem release]; +} + +/* Replacement for NSApplicationMain */ +static void CustomApplicationMain (int argc, char **argv) +{ + NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; + SDLMain *sdlMain; + + /* Ensure the application object is initialised */ + [SDLApplication sharedApplication]; + +#ifdef SDL_USE_CPS + { + CPSProcessSerNum PSN; + /* Tell the dock about us */ + if (!CPSGetCurrentProcess(&PSN)) + if (!CPSEnableForegroundOperation(&PSN,0x03,0x3C,0x2C,0x1103)) + if (!CPSSetFrontProcess(&PSN)) + [SDLApplication sharedApplication]; + } +#endif /* SDL_USE_CPS */ + + /* Set up the menubar */ + NSMenu *menu = [[NSMenu alloc] init]; + [NSApp setMainMenu:menu]; + setApplicationMenu(); + setupWindowMenu(); + [menu release]; + + /* Create SDLMain and make it the app delegate */ + sdlMain = [[SDLMain alloc] init]; + [NSApp setDelegate:sdlMain]; + + /* Start the main event loop */ + [NSApp run]; + + [sdlMain release]; + [pool release]; +} + +#endif + + +/* + * Catch document open requests...this lets us notice files when the app + * was launched by double-clicking a document, or when a document was + * dragged/dropped on the app's icon. You need to have a + * CFBundleDocumentsType section in your Info.plist to get this message, + * apparently. + * + * Files are added to gArgv, so to the app, they'll look like command line + * arguments. Previously, apps launched from the finder had nothing but + * an argv[0]. + * + * This message may be received multiple times to open several docs on launch. + * + * This message is ignored once the app's mainline has been called. + */ +- (BOOL)application:(NSApplication *)theApplication openFile:(NSString *)filename +{ + const char *temparg; + size_t arglen; + char *arg; + char **newargv; + + if (!gFinderLaunch) /* MacOS is passing command line args. */ + return FALSE; + + if (gCalledAppMainline) /* app has started, ignore this document. */ + return FALSE; + + temparg = [filename UTF8String]; + arglen = SDL_strlen(temparg) + 1; + arg = (char *) SDL_malloc(arglen); + if (arg == NULL) + return FALSE; + + newargv = (char **) realloc(gArgv, sizeof (char *) * (gArgc + 2)); + if (newargv == NULL) + { + SDL_free(arg); + return FALSE; + } + gArgv = newargv; + + SDL_strlcpy(arg, temparg, arglen); + gArgv[gArgc++] = arg; + gArgv[gArgc] = NULL; + return TRUE; +} + + +/* Called when the internal event loop has just started running */ +- (void) applicationDidFinishLaunching: (NSNotification *) note +{ + int status; + + /* Set the working directory to the .app's parent directory */ + [self setupWorkingDirectory:gFinderLaunch]; + +#if SDL_USE_NIB_FILE + /* Set the main menu to contain the real app name instead of "SDL App" */ + [self fixMenu:[NSApp mainMenu] withAppName:getApplicationName()]; +#endif + + /* Hand off to main application code */ + gCalledAppMainline = TRUE; + status = SDL_main (gArgc, gArgv); + + /* We're done, thank you for playing */ + exit(status); +} +@end + + +@implementation NSString (ReplaceSubString) + +- (NSString *)stringByReplacingRange:(NSRange)aRange with:(NSString *)aString +{ + unsigned int bufferSize; + unsigned int selfLen = [self length]; + unsigned int aStringLen = [aString length]; + unichar *buffer; + NSRange localRange; + NSString *result; + + bufferSize = selfLen + aStringLen - aRange.length; + buffer = (unichar *)NSAllocateMemoryPages(bufferSize*sizeof(unichar)); + + /* Get first part into buffer */ + localRange.location = 0; + localRange.length = aRange.location; + [self getCharacters:buffer range:localRange]; + + /* Get middle part into buffer */ + localRange.location = 0; + localRange.length = aStringLen; + [aString getCharacters:(buffer+aRange.location) range:localRange]; + + /* Get last part into buffer */ + localRange.location = aRange.location + aRange.length; + localRange.length = selfLen - localRange.location; + [self getCharacters:(buffer+aRange.location+aStringLen) range:localRange]; + + /* Build output string */ + result = [NSString stringWithCharacters:buffer length:bufferSize]; + + NSDeallocateMemoryPages(buffer, bufferSize); + + return result; +} + +@end + + + +#ifdef main +# undef main +#endif + + +/* Main entry point to executable - should *not* be SDL_main! */ +int main (int argc, char **argv) +{ + /* Copy the arguments into a global variable */ + /* This is passed if we are launched by double-clicking */ + if ( argc >= 2 && strncmp (argv[1], "-psn", 4) == 0 ) { + gArgv = (char **) SDL_malloc(sizeof (char *) * 2); + gArgv[0] = argv[0]; + gArgv[1] = NULL; + gArgc = 1; + gFinderLaunch = YES; + } else { + int i; + gArgc = argc; + gArgv = (char **) SDL_malloc(sizeof (char *) * (argc+1)); + for (i = 0; i <= argc; i++) + gArgv[i] = argv[i]; + gFinderLaunch = NO; + } + +#if SDL_USE_NIB_FILE + [SDLApplication poseAsClass:[NSApplication class]]; + NSApplicationMain (argc, argv); +#else + CustomApplicationMain (argc, argv); +#endif + return 0; +} + diff -r 2286a39140da -r 453917e94e55 hedgewars/uAI.pas --- a/hedgewars/uAI.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uAI.pas Thu Nov 22 00:41:53 2012 +0100 @@ -33,6 +33,11 @@ uAmmos, SysUtils{$IFNDEF USE_SDLTHREADS} {$IFDEF UNIX}, cthreads{$ENDIF} {$ENDIF}, uTypes, uVariables, uCommands, uUtils, uDebug, uAILandMarks; +{$IFDEF AI_MAINTHREAD} +const + mainThreadMaxThinkTime:Integer = 1500; +{$ENDIF} + var BestActions: TActions; CanUseAmmo: array [TAmmoType] of boolean; StopThinking: boolean; @@ -42,7 +47,7 @@ ThinkThread: TThreadID; {$ENDIF} hasThread: LongInt; - StartTicks: Longword; + StartTicks: LongInt; procedure FreeActionsList; begin @@ -332,7 +337,7 @@ end; // 'not CanGO' means we can't go straight, possible jumps are checked above - if not CanGo then + if (not CanGo) then break; inc(steps); @@ -360,6 +365,15 @@ if GoInfo.FallPix >= FallPixForBranching then Push(ticks, Actions, Me^, Me^.Message xor 3); // aia_Left xor 3 = aia_Right + +{$IFDEF AI_MAINTHREAD} + if StartTicks < (SDL_GetTicks() - mainThreadMaxThinkTime) then + StopThinking := true; +{$ELSE} + if (StartTicks > GameTicks - 1500) and (not StopThinking) then + SDL_Delay(1000); +{$ENDIF} + end {while}; if BestRate > BaseRate then @@ -371,12 +385,18 @@ function Think(Me: Pointer): ptrint; var BackMe, WalkMe: TGear; switchCount: LongInt; - StartTicks, currHedgehogIndex, itHedgehog, switchesNum, i: Longword; + currHedgehogIndex, itHedgehog, switchesNum, i: Longword; switchImmediatelyAvailable: boolean; Actions: TActions; begin InterlockedIncrement(hasThread); + +{$IFDEF AI_MAINTHREAD} +StartTicks:= SDL_GetTicks(); +{$ELSE} StartTicks:= GameTicks; +{$ENDIF} + currHedgehogIndex:= CurrentTeam^.CurrHedgehog; itHedgehog:= currHedgehogIndex; switchesNum:= 0; @@ -386,7 +406,7 @@ switchCount:= HHHasAmmo(PGear(Me)^.Hedgehog^, amSwitch) else switchCount:= 0; -if (PGear(Me)^.State and gstAttacked) = 0 then +if (PGear(Me)^.State and gstAttacking) = 0 then if Targets.Count > 0 then begin // iterate over current team hedgehogs @@ -398,7 +418,7 @@ Actions.Score:= 0; if switchesNum > 0 then begin - if not switchImmediatelyAvailable then + if (not switchImmediatelyAvailable) then begin // when AI has to use switcher, make it cost smth unless they have a lot of switches if (switchCount < 10) then Actions.Score:= (-27+switchCount*3)*4000; @@ -423,8 +443,13 @@ or (itHedgehog = currHedgehogIndex) or BestActions.isWalkingToABetterPlace; - if (StartTicks > GameTicks - 1500) and (not StopThinking) then - SDL_Delay(1000); + {$IFDEF AI_MAINTHREAD} + if StartTicks < (SDL_GetTicks() - mainThreadMaxThinkTime) then + StopThinking := true; + {$ELSE} + if (StartTicks > GameTicks - 1500) and (not StopThinking) then + SDL_Delay(1000); + {$ENDIF} if (BestActions.Score < -1023) and (not BestActions.isWalkingToABetterPlace) then begin @@ -436,22 +461,29 @@ else begin BackMe:= PGear(Me)^; + +//{$IFNDEF AI_MAINTHREAD} while (not StopThinking) and (BestActions.Count = 0) do begin + (* // Maybe this would get a bit of movement out of them? Hopefully not *toward* water. Need to check how often he'd choose that strategy if SuddenDeathDmg and ((hwRound(BackMe.Y)+cWaterRise*2) > cWaterLine) then AddBonus(hwRound(BackMe.X), hwRound(BackMe.Y), 250, -40); *) + FillBonuses(true); WalkMe:= BackMe; Actions.Count:= 0; Actions.Pos:= 0; Actions.Score:= 0; Walk(@WalkMe, Actions); - if not StopThinking then +{$IFNDEF AI_MAINTHREAD} + if (not StopThinking) then SDL_Delay(100) +{$ENDIF} end +//{$ENDIF} end; PGear(Me)^.State:= PGear(Me)^.State and (not gstHHThinking); @@ -487,12 +519,17 @@ FillBonuses((Me^.State and gstAttacked) <> 0); AddFileLog('Enter Think Thread'); + +{$IFDEF AI_MAINTHREAD} +Think(Me); +{$ELSE} {$IFDEF USE_SDLTHREADS} ThinkThread := SDL_CreateThread(@Think{$IFDEF SDL13}, nil{$ENDIF}, Me); {$ELSE} BeginThread(@Think, Me, ThinkThread); {$ENDIF} AddFileLog('Thread started'); +{$ENDIF} end; //var scoreShown: boolean = false; @@ -539,7 +576,9 @@ begin hasThread:= 0; StartTicks:= 0; +{$IFNDEF PAS2C} ThinkThread:= ThinkThread; +{$ENDIF} end; procedure freeModule; diff -r 2286a39140da -r 453917e94e55 hedgewars/uAIAmmoTests.pas --- a/hedgewars/uAIAmmoTests.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uAIAmmoTests.pas Thu Nov 22 00:41:53 2012 +0100 @@ -764,7 +764,7 @@ Targ:= Targ; // avoid compiler hint if Level < 3 then trackFall:= afTrackFall - else trackFall:= 0; + else trackFall:= 0; ap.ExplR:= 0; ap.Time:= 0; @@ -1107,7 +1107,7 @@ begin maxTop := Targ.Y - cHHRadius * 2; - while not TestColl(Targ.X, maxTop, cHHRadius) and (maxTop > topY + cHHRadius * 2 + 1) do + while (not TestColl(Targ.X, maxTop, cHHRadius)) and (maxTop > topY + cHHRadius * 2 + 1) do dec(maxTop, cHHRadius*2); if not TestColl(Targ.X, maxTop + cHHRadius, cHHRadius) then begin diff -r 2286a39140da -r 453917e94e55 hedgewars/uAIMisc.pas --- a/hedgewars/uAIMisc.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uAIMisc.pas Thu Nov 22 00:41:53 2012 +0100 @@ -49,7 +49,17 @@ X, Y: LongInt; Radius: LongInt; Score: LongInt; - end; + end; + +Tbonuses = record + Count : Longword; + ar : array[0..Pred(MAXBONUS)] of TBonus; + end; + +Twalkbonuses = record + Count: Longword; + ar: array[0..Pred(MAXBONUS div 8)] of TBonus; // don't use too many + end; procedure initModule; procedure freeModule; @@ -77,15 +87,9 @@ var ThinkingHH: PGear; Targets: TTargets; - bonuses: record - Count: Longword; - ar: array[0..Pred(MAXBONUS)] of TBonus; - end; + bonuses: Tbonuses; - walkbonuses: record - Count: Longword; - ar: array[0..Pred(MAXBONUS div 8)] of TBonus; // don't use too many - end; + walkbonuses: Twalkbonuses; const KillScore = 200; var friendlyfactor: LongInt = 300; @@ -353,7 +357,7 @@ y:= y + dY; dY:= dY + cGravityf; skipLandCheck:= skipLandCheck and (r <> 0) and (abs(eX-x) + abs(eY-y) < r) and ((abs(eX-x) < rCorner) or (abs(eY-y) < rCorner)); - if not skipLandCheck and TestCollWithLand(trunc(x), trunc(y), cHHRadius) then + if (not skipLandCheck) and TestCollWithLand(trunc(x), trunc(y), cHHRadius) then begin if 0.4 < dY then begin diff -r 2286a39140da -r 453917e94e55 hedgewars/uAmmos.pas --- a/hedgewars/uAmmos.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uAmmos.pas Thu Nov 22 00:41:53 2012 +0100 @@ -257,7 +257,7 @@ Ammo^[Slot, ami]:= Ammo^[Slot, ami + 1]; Ammo^[Slot, ami + 1].Count:= 0 end; - until not b; + until (not b); AmmoMenuInvalidated:= true; end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uCaptions.pas --- a/hedgewars/uCaptions.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uCaptions.pas Thu Nov 22 00:41:53 2012 +0100 @@ -45,6 +45,8 @@ procedure AddCaption(s: shortstring; Color: Longword; Group: TCapGroup); begin if cOnlyStats then exit; + if Length(s) = 0 then + exit; if Captions[Group].Text <> s then begin FreeTexture(Captions[Group].Tex); diff -r 2286a39140da -r 453917e94e55 hedgewars/uChat.pas --- a/hedgewars/uChat.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uChat.pas Thu Nov 22 00:41:53 2012 +0100 @@ -211,7 +211,7 @@ else if (s[1] = '-') and (s[Length(s)] = '-') then x:= 3; -if not CurrentTeam^.ExtDriven and (x <> 0) then +if (not CurrentTeam^.ExtDriven) and (x <> 0) then for c:= 0 to Pred(TeamsCount) do if (TeamsArray[c] = CurrentTeam) then t:= c; diff -r 2286a39140da -r 453917e94e55 hedgewars/uCommandHandlers.pas --- a/hedgewars/uCommandHandlers.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uCommandHandlers.pas Thu Nov 22 00:41:53 2012 +0100 @@ -185,37 +185,37 @@ procedure chCurD_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint CursorMovementY:= 0; end; procedure chCurL_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint CursorMovementX:= -1; end; procedure chCurL_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint CursorMovementX:= 0; end; procedure chCurR_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint CursorMovementX:= 1; end; procedure chCurR_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint CursorMovementX:= 0; end; procedure chLeft_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -228,7 +228,7 @@ procedure chLeft_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; if not isExternalSource then @@ -240,7 +240,7 @@ procedure chRight_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -253,7 +253,7 @@ procedure chRight_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; if not isExternalSource then @@ -265,7 +265,7 @@ procedure chUp_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -278,7 +278,7 @@ procedure chUp_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; if not isExternalSource then @@ -290,7 +290,7 @@ procedure chDown_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -303,7 +303,7 @@ procedure chDown_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; if not isExternalSource then @@ -315,7 +315,7 @@ procedure chPrecise_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -328,7 +328,7 @@ procedure chPrecise_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; if not isExternalSource then @@ -340,7 +340,7 @@ procedure chLJump(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -353,7 +353,7 @@ procedure chHJump(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -366,7 +366,7 @@ procedure chAttack_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; bShowFinger:= false; @@ -386,7 +386,7 @@ procedure chAttack_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then exit; with CurrentHedgehog^.Gear^ do @@ -401,7 +401,7 @@ procedure chSwitch(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; if not isExternalSource then @@ -413,9 +413,10 @@ end; procedure chNextTurn(var s: shortstring); -var gi: PGear; +var i : Longword; + gi : PGear; begin - s:= s; // avoid compiler hint + s:=s; // avoid compiler hint TryDo(AllInactive, '/nextturn called when not all gears are inactive', true); @@ -522,13 +523,13 @@ procedure chPut(var s: shortstring); begin - s:= s; // avoid compiler hint + s:=s; // avoid compiler hint doPut(0, 0, false); end; procedure chCapture(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint flagMakeCapture:= true end; @@ -579,7 +580,7 @@ procedure chAmmoMenu(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH then bShowAmmoMenu:= true else @@ -604,19 +605,19 @@ procedure chVol_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint inc(cVolumeDelta, 3) end; procedure chVol_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint dec(cVolumeDelta, 3) end; procedure chFindhh(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if CheckNoTeamOrHH or isPaused then exit; @@ -638,7 +639,7 @@ procedure chPause(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if gameType <> gmtNet then isPaused:= not isPaused; @@ -650,7 +651,7 @@ procedure chRotateMask(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint if ((GameFlags and gfInvulnerable) = 0) then cTagsMask:= cTagsMasks[cTagsMask] else @@ -659,34 +660,34 @@ procedure chSpeedup_p(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint SpeedStart:= RealTicks; isSpeed:= true end; procedure chSpeedup_m(var s: shortstring); begin -s:= s; // avoid compiler hint +s:=s; // avoid compiler hint isSpeed:= false end; procedure chZoomIn(var s: shortstring); begin - s:= s; // avoid compiler hint + s:=s; // avoid compiler hint if ZoomValue < cMinZoomLevel then ZoomValue:= ZoomValue + cZoomDelta; end; procedure chZoomOut(var s: shortstring); begin - s:= s; // avoid compiler hint + s:=s; // avoid compiler hint if ZoomValue > cMaxZoomLevel then ZoomValue:= ZoomValue - cZoomDelta; end; procedure chZoomReset(var s: shortstring); begin - s:= s; // avoid compiler hint + s:=s; // avoid compiler hint ZoomValue:= cDefaultZoomLevel; end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uConsts.pas --- a/hedgewars/uConsts.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uConsts.pas Thu Nov 22 00:41:53 2012 +0100 @@ -149,7 +149,7 @@ cBlowTorchC = 6; cakeDmg = 75; - cKeyMaxIndex = 1023; + cKeyMaxIndex = 1600; cKbdMaxIndex = 65536;//need more room for the modifier keys cHHFileName = 'Hedgehog'; diff -r 2286a39140da -r 453917e94e55 hedgewars/uCursor.pas --- a/hedgewars/uCursor.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uCursor.pas Thu Nov 22 00:41:53 2012 +0100 @@ -9,6 +9,10 @@ uses SDLh, uVariables; +{$IFDEF WEBGL} +var offsetx, offsety : Integer; +{$ENDIF} + procedure init; begin SDL_WarpMouse(cScreenWidth div 2, cScreenHeight div 2); @@ -16,16 +20,33 @@ procedure updatePosition; var x, y: LongInt; +{$IFDEF WEBGL} + tx, ty : LongInt; +{$ENDIF} begin SDL_GetMouseState(@x, @y); +{$IFDEF WEBGL} + tx := x; + ty := y; + x := x + offsetx; + y := y + offsety; +{$ENDIF} + if(x <> cScreenWidth div 2) or (y <> cScreenHeight div 2) then begin CursorPoint.X:= CursorPoint.X + x - cScreenWidth div 2; CursorPoint.Y:= CursorPoint.Y - y + cScreenHeight div 2; if cHasFocus then + begin + {$IFNDEF WEBGL} SDL_WarpMouse(cScreenWidth div 2, cScreenHeight div 2); + {$ELSE} + offsetx := cScreenWidth div 2 - tx; + offsety := cScreenHeight div 2 - ty; + {$ENDIF} + end; end end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uFloat.pas --- a/hedgewars/uFloat.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uFloat.pas Thu Nov 22 00:41:53 2012 +0100 @@ -55,7 +55,7 @@ 1: (QWordValue : QWord); end; {$ENDIF} - + // Returns an hwFloat that represents the value of integer parameter i function int2hwFloat (const i: LongInt) : hwFloat; inline; function hwFloat2Float (const i: hwFloat) : extended; inline; @@ -221,7 +221,7 @@ hwFloat2Float:= -hwFloat2Float; end; -{$IFNDEF WEB} +{$IFNDEF WEBGL} operator = (const z1, z2: hwFloat) z : boolean; inline; begin z:= (z1.isNegative = z2.isNegative) and (z1.QWordValue = z2.QWordValue); @@ -301,7 +301,7 @@ b:= (z1.QWordValue > z2.QWordValue) <> z2.isNegative end; {$ENDIF} -{$IFDEF WEB} +{$IFDEF WEBGL} (* Mostly to be kind to JS as of 2012-08-27 where there is no int64/uint64. This may change though. *) diff -r 2286a39140da -r 453917e94e55 hedgewars/uGears.pas --- a/hedgewars/uGears.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uGears.pas Thu Nov 22 00:41:53 2012 +0100 @@ -54,7 +54,6 @@ function GearByUID(uid : Longword) : PGear; procedure doStepDrowningGear(Gear: PGear); - implementation uses uStore, uSound, uTeams, uRandom, uCollisions, uIO, uLandGraphics, uLocale, uAI, uAmmos, uStats, uVisualGears, uScript, GLunit, uMobile, uVariables, @@ -600,6 +599,7 @@ var i,rx, ry: Longword; rdx, rdy: hwFloat; Gear: PGear; + temp: Longword; begin AddGear(0, 0, gtATStartGame, 0, _0, _0, 2000); diff -r 2286a39140da -r 453917e94e55 hedgewars/uGearsHedgehog.pas --- a/hedgewars/uGearsHedgehog.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uGearsHedgehog.pas Thu Nov 22 00:41:53 2012 +0100 @@ -1122,7 +1122,7 @@ exit end; - if not isInMultiShoot and (Hedgehog^.Gear <> nil) then + if (not isInMultiShoot) and (Hedgehog^.Gear <> nil) then begin if GHStepTicks > 0 then dec(GHStepTicks); diff -r 2286a39140da -r 453917e94e55 hedgewars/uGearsList.pas --- a/hedgewars/uGearsList.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uGearsList.pas Thu Nov 22 00:41:53 2012 +0100 @@ -83,8 +83,10 @@ var gear: PGear; begin inc(GCounter); + AddFileLog('AddGear: #' + inttostr(GCounter) + ' (' + inttostr(x) + ',' + inttostr(y) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind)); + New(gear); FillChar(gear^, sizeof(TGear), 0); gear^.X:= int2hwFloat(X); @@ -525,7 +527,7 @@ begin t:= max(Gear^.Damage, Gear^.Health); Gear^.Damage:= t; - if ((not SuddenDeathDmg and (WaterOpacity < $FF)) or (SuddenDeathDmg and (WaterOpacity < $FF))) + if (((not SuddenDeathDmg) and (WaterOpacity < $FF)) or (SuddenDeathDmg and (WaterOpacity < $FF))) and (hwRound(Gear^.Y) < cWaterLine + 256) then spawnHealthTagForHH(Gear, t); end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uGearsRender.pas --- a/hedgewars/uGearsRender.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uGearsRender.pas Thu Nov 22 00:41:53 2012 +0100 @@ -23,18 +23,21 @@ interface uses uTypes, uConsts, GLunit, uFloat, SDLh; +type + Tar = record + X, Y: hwFloat; + dLen: hwFloat; + b : boolean; + end; + TRopePoints = record + Count : Longword; + HookAngle : GLfloat; + ar : array[0..MAXROPEPOINTS] of Tar; + rounded : array[0..MAXROPEPOINTS + 2] of TVertex2f; + end; procedure RenderGear(Gear: PGear; x, y: LongInt); -var RopePoints: record - Count: Longword; - HookAngle: GLfloat; - ar: array[0..MAXROPEPOINTS] of record - X, Y: hwFloat; - dLen: hwFloat; - b: boolean; - end; - rounded: array[0..MAXROPEPOINTS + 2] of TVertex2f; - end; +var RopePoints: TRopePoints; implementation uses uRender, uUtils, uVariables, uAmmos, Math, uVisualGears; @@ -82,6 +85,7 @@ if (X1 = X2) and (Y1 = Y2) then begin //OutError('WARNING: zero length rope line!', false); + DrawRopeLine := 0; exit end; eX:= 0; @@ -1165,7 +1169,7 @@ begin if isInLag and (Gear^.FlightTime < 256) then inc(Gear^.FlightTime, 8) - else if not isInLag and (Gear^.FlightTime > 0) then + else if (not isInLag) and (Gear^.FlightTime > 0) then dec(Gear^.FlightTime, 8); if Gear^.FlightTime > 0 then Tint($FF, $FF, $FF, $FF-min(255,Gear^.FlightTime)); diff -r 2286a39140da -r 453917e94e55 hedgewars/uGearsUtils.pas --- a/hedgewars/uGearsUtils.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uGearsUtils.pas Thu Nov 22 00:41:53 2012 +0100 @@ -557,6 +557,7 @@ y, sy: LongInt; ar: array[0..1023] of TPoint; ar2: array[0..2047] of TPoint; + temp: TPoint; cnt, cnt2: Longword; delta: LongInt; ignoreNearObjects, ignoreOverlap, tryAgain: boolean; @@ -579,7 +580,7 @@ repeat inc(y, 2); until (y >= cWaterLine) or - (not ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) = 0)) or + ((not ignoreOverlap) and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) = 0)) or (ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FF00) = 0)); sy:= y; @@ -587,7 +588,7 @@ repeat inc(y); until (y >= cWaterLine) or - (not ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) <> 0)) or + ((not ignoreOverlap) and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FFFF) <> 0)) or (ignoreOverlap and (CountNonZeroz(x, y, Gear^.Radius - 1, 1, $FF00) <> 0)); if (y - sy > Gear^.Radius * 2) @@ -613,12 +614,15 @@ end; if cnt > 0 then - with ar[GetRandom(cnt)] do + begin + temp := ar[GetRandom(cnt)]; + with temp do begin ar2[cnt2].x:= x; ar2[cnt2].y:= y; inc(cnt2) - end + end + end until (x + Delta > Right); dec(Delta, 60) @@ -632,12 +636,15 @@ end; if cnt2 > 0 then - with ar2[GetRandom(cnt2)] do + begin + temp := ar2[GetRandom(cnt2)]; + with temp do begin Gear^.X:= int2hwFloat(x); Gear^.Y:= int2hwFloat(y); AddFileLog('Assigned Gear coordinates (' + inttostr(x) + ',' + inttostr(y) + ')'); end + end else begin OutError('Can''t find place for Gear', false); diff -r 2286a39140da -r 453917e94e55 hedgewars/uIO.pas --- a/hedgewars/uIO.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uIO.pas Thu Nov 22 00:41:53 2012 +0100 @@ -20,7 +20,7 @@ unit uIO; interface -uses SDLh, uTypes; +uses SDLh, uTypes, uMisc; procedure initModule; procedure freeModule; @@ -114,6 +114,7 @@ procedure ParseIPCCommand(s: shortstring); var loTicks: Word; begin + case s[1] of '!': begin AddFileLog('Ping? Pong!'); isPonged:= true; end; '?': SendIPC(_S'!'); @@ -168,10 +169,11 @@ end; procedure LoadRecordFromFile(fileName: shortstring); -var f: file; - ss: shortstring = ''; - i: LongInt; - s: shortstring; +var f : File; + ss : shortstring = ''; + i : LongInt; + s : shortstring; + t, tt : string; begin // set RDNLY on file open @@ -179,7 +181,6 @@ {$I-} assign(f, fileName); reset(f, 1); - tryDo(IOResult = 0, 'Error opening file ' + fileName, true); i:= 0; // avoid compiler hints @@ -187,13 +188,13 @@ repeat BlockRead(f, s[1], 255 - Length(ss), i); if i > 0 then - begin + begin s[0]:= char(i); ss:= ss + s; while (Length(ss) > 1)and(Length(ss) > byte(ss[1])) do begin ParseIPCCommand(copy(ss, 2, byte(ss[1]))); - Delete(ss, 1, Succ(byte(ss[1]))) + Delete(ss, 1, Succ(byte(ss[1]))); end end until i = 0; @@ -222,7 +223,8 @@ SDLNet_Write16(GameTicks, @s[Succ(byte(s[0]))]); AddFileLog('[IPC out] '+ s[1]); inc(s[0], 2); - SDLNet_TCP_Send(IPCSock, @s, Succ(byte(s[0]))) + SDLNet_TCP_Send(IPCSock, @s, Succ(byte(s[0]))); + //log('SendIPC'); end end; @@ -376,7 +378,7 @@ if CheckNoTeamOrHH or isPaused then exit; bShowFinger:= false; -if not CurrentTeam^.ExtDriven and bShowAmmoMenu then +if (not CurrentTeam^.ExtDriven) and bShowAmmoMenu then begin bSelected:= true; exit @@ -429,6 +431,7 @@ hiTicks:= 0; SendEmptyPacketTicks:= 0; + end; procedure freeModule; @@ -437,6 +440,7 @@ SDLNet_FreeSocketSet(fds); SDLNet_TCP_Close(IPCSock); SDLNet_Quit(); + end; end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uLand.pas --- a/hedgewars/uLand.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLand.pas Thu Nov 22 00:41:53 2012 +0100 @@ -240,6 +240,7 @@ rightX:= (playWidth + ((LAND_WIDTH - playWidth) div 2)) - 1; topY:= LAND_HEIGHT - playHeight; + // HACK: force to only cavern even if a cavern map is invertable if cTemplateFilter = 4 ? if (cTemplateFilter = 4) or (Template.canInvert and (getrandom(2) = 0)) @@ -522,9 +523,11 @@ end; procedure LoadMap; -var tmpsurf: PSDL_Surface; - s: shortstring; - mapName: shortstring = ''; +var tmpsurf : PSDL_Surface; + s : shortstring; + f : textfile; + mapName : shortstring = ''; + begin WriteLnToConsole('Loading land from file...'); AddProgress; @@ -553,9 +556,11 @@ LAND_HEIGHT - tmpsurf^.h, tmpsurf^.w, tmpsurf); + SDL_FreeSurface(tmpsurf); LoadMask; + end; procedure DrawBottomBorder; // broken out from other borders for doing a floor-only map, or possibly updating bottom during SD @@ -620,7 +625,6 @@ MakeFortsMap; AddProgress; - // check for land near top c:= 0; if (GameFlags and gfBorder) <> 0 then @@ -788,8 +792,10 @@ var adler, i: LongInt; begin adler:= 1; - for i:= 0 to LAND_HEIGHT-1 do + for i:= 0 to LAND_HEIGHT-1 do + begin adler:= Adler32Update(adler, @Land[i,0], LAND_WIDTH); + end; s:= 'M' + IntToStr(adler) + cScriptName; chLandCheck(s); diff -r 2286a39140da -r 453917e94e55 hedgewars/uLandGenMaze.pas --- a/hedgewars/uLandGenMaze.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLandGenMaze.pas Thu Nov 22 00:41:53 2012 +0100 @@ -14,6 +14,10 @@ DIR_S: direction = (x: 0; y: 1); DIR_W: direction = (x: -1; y: 0); +{xymeng : make all dynamic arrays static } +const max_num_cells_x = 4096 div 128; + max_num_cells_y = 4096 div 128; + max_num_steps = 3; operator = (const a, b: direction) c: Boolean; begin @@ -25,28 +29,43 @@ large_cell_size = 256; braidness = 10; -var x, y: LongInt; - cellsize: LongInt; //selected by the user in the gui - seen_cells_x, seen_cells_y: LongInt; //number of cells that can be visited by the generator, that is every second cell in x and y direction. the cells between there are walls that will be removed when we move from one cell to another - num_edges_x, num_edges_y: LongInt; //number of resulting edges that need to be vertexificated - num_cells_x, num_cells_y: LongInt; //actual number of cells, depending on cell size - seen_list: array of array of LongInt; - xwalls: array of array of Boolean; - ywalls: array of array of Boolean; - x_edge_list: array of array of Boolean; - y_edge_list: array of array of Boolean; - maze: array of array of Boolean; - pa: TPixAr; - num_vertices: LongInt; - off_y: LongInt; - num_steps: LongInt; - current_step: LongInt; - step_done: array of Boolean; - done: Boolean; - last_cell: array of record x, y: LongInt; end; - came_from: array of array of record x, y: LongInt; end; +type + cell_t = record x,y : LongInt + end; + +var x, y : LongInt; + cellsize : LongInt; //selected by the user in the gui + seen_cells_x, seen_cells_y : LongInt; //number of cells that can be visited by the generator, that is every second cell in x and y direction. the cells between there are walls that will be removed when we move from one cell to another + num_edges_x, num_edges_y : LongInt; //number of resulting edges that need to be vertexificated + num_cells_x, num_cells_y : LongInt; //actual number of cells, depending on cell size + + + seen_list : array of array of LongInt; + xwalls : array of array of Boolean; + ywalls : array of array of Boolean; + x_edge_list : array of array of Boolean; + y_edge_list : array of array of Boolean; + maze : array of array of Boolean; + + pa : TPixAr; + num_vertices : LongInt; + off_y : LongInt; + num_steps : LongInt; + current_step : LongInt; + + step_done : array of Boolean; + + done : Boolean; + +{ last_cell : array 0..3 of record x, y :LongInt ; end; + came_from : array of array of record x, y: LongInt; end; + came_from_pos : array of LongInt; +} + last_cell : array of cell_t; + came_from : array of array of cell_t; came_from_pos: array of LongInt; - maze_inverted: Boolean; + + maze_inverted : Boolean; function when_seen(x: LongInt; y: LongInt): LongInt; begin @@ -102,7 +121,7 @@ begin //we have already seen the target cell, decide if we should remove the wall anyway //(or put a wall there if maze_inverted, but we are not doing that right now) - if not maze_inverted and (GetRandom(braidness) = 0) then + if (not maze_inverted) and (GetRandom(braidness) = 0) then //or just warn that inverted+braid+indestructible terrain != good idea begin case dir.x of @@ -178,7 +197,7 @@ came_from_pos[current_step] := came_from_pos[current_step] - 1; if came_from_pos[current_step] >= 0 then - see_cell + see_cell() else step_done[current_step] := true; @@ -336,14 +355,18 @@ SetLength(last_cell, num_steps); SetLength(came_from_pos, num_steps); SetLength(came_from, num_steps, num_cells_x*num_cells_y); + done := false; for current_step := 0 to num_steps - 1 do +begin step_done[current_step] := false; came_from_pos[current_step] := 0; - +end; + current_step := 0; + SetLength(seen_list, seen_cells_x, seen_cells_y); SetLength(xwalls, seen_cells_x, seen_cells_y - 1); SetLength(ywalls, seen_cells_x - 1, seen_cells_y); @@ -351,6 +374,7 @@ SetLength(y_edge_list, num_cells_x, num_edges_y); SetLength(maze, num_cells_x, num_cells_y); + num_vertices := 0; playHeight := num_cells_y * cellsize; diff -r 2286a39140da -r 453917e94e55 hedgewars/uLandGraphics.pas --- a/hedgewars/uLandGraphics.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLandGraphics.pas Thu Nov 22 00:41:53 2012 +0100 @@ -208,7 +208,7 @@ t:= y + dy; if (t and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do - if ((Land[t, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[t, i] > 255)) then + if ((Land[t, i] and lfIndestructible) = 0) and ((not disableLandBack) or (Land[t, i] > 255)) then if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[t, i]:= 0 else @@ -217,7 +217,7 @@ t:= y - dy; if (t and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do - if ((Land[t, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[t, i] > 255)) then + if ((Land[t, i] and lfIndestructible) = 0) and ((not disableLandBack) or (Land[t, i] > 255)) then if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[t, i]:= 0 else @@ -226,7 +226,7 @@ t:= y + dx; if (t and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do - if ((Land[t, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[t, i] > 255)) then + if ((Land[t, i] and lfIndestructible) = 0) and ((not disableLandBack) or (Land[t, i] > 255)) then if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[t, i]:= 0 else @@ -235,7 +235,7 @@ t:= y - dx; if (t and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do - if ((Land[t, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[t, i] > 255)) then + if ((Land[t, i] and lfIndestructible) = 0) and ((not disableLandBack) or (Land[t, i] > 255)) then if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[t, i]:= 0 else diff -r 2286a39140da -r 453917e94e55 hedgewars/uLandObjects.pas --- a/hedgewars/uLandObjects.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLandObjects.pas Thu Nov 22 00:41:53 2012 +0100 @@ -67,6 +67,8 @@ ThemeObjects: TThemeObjects; SprayObjects: TSprayObjects; + + procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface); inline; begin BlitImageAndGenerateCollisionInfo(cpX, cpY, Width, Image, 0); diff -r 2286a39140da -r 453917e94e55 hedgewars/uLandTemplates.pas --- a/hedgewars/uLandTemplates.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLandTemplates.pas Thu Nov 22 00:41:53 2012 +0100 @@ -24,20 +24,20 @@ const NTPX = Low(SmallInt); -type TPointArray = array[0..64] of TSDL_Rect; - PPointArray = ^TPointArray; +type TPointArray = array[0..64] of TSDL_Rect; + PPointArray = ^TPointArray; TEdgeTemplate = record - BasePoints: PPointArray; - BasePointsCount: Longword; - FillPoints: PPointArray; - FillPointsCount: Longword; - BezierizeCount: Longword; - RandPassesCount: Longword; - TemplateHeight, TemplateWidth: Longword; - canMirror, canFlip, isNegative, canInvert: boolean; - hasGirders: boolean; - MaxHedgeHogs: Longword; - end; + BasePoints : PPointArray; + BasePointsCount : Longword; + FillPoints : PPointArray; + FillPointsCount : Longword; + BezierizeCount : Longword; + RandPassesCount : Longword; + TemplateHeight, TemplateWidth : Longword; + canMirror, canFlip, isNegative, canInvert : boolean; + hasGirders : boolean; + MaxHedgeHogs : Longword; + end; ///////////////////////// ORIGINAL SET ////////////////////////////// /// Area expanded to 2848x1424 at Tiys request to move out border /// ///////////////////////////////////////////////////////////////////// @@ -63,9 +63,9 @@ (x: 2134; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template0FPoints: array[0..0] of TPoint = + Template0FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template1Points: array[0..15] of TSDL_Rect = @@ -87,9 +87,9 @@ (x: 1860; y: 1424; w: 25; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template1FPoints: array[0..0] of TPoint = + Template1FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template2Points: array[0..21] of TSDL_Rect = @@ -117,9 +117,9 @@ (x: 2004; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template2FPoints: array[0..0] of TPoint = + Template2FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template3Points: array[0..16] of TSDL_Rect = @@ -142,9 +142,9 @@ (x: 1834; y: 622; w: 254; h: 116), (x: NTPX; y: 0; w: 1; h: 1) ); - Template3FPoints: array[0..0] of TPoint = + Template3FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template4Points: array[0..22] of TSDL_Rect = @@ -173,9 +173,9 @@ (x: 2150; y: 552; w: 86; h: 220), (x: NTPX; y: 0; w: 1; h: 1) ); - Template4FPoints: array[0..0] of TPoint = + Template4FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template5Points: array[0..15] of TSDL_Rect = @@ -197,9 +197,9 @@ (x: 2012; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template5FPoints: array[0..0] of TPoint = + Template5FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template6Points: array[0..13] of TSDL_Rect = @@ -219,9 +219,9 @@ (x: 2046; y: 1420; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template6FPoints: array[0..0] of TPoint = + Template6FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template7Points: array[0..5] of TSDL_Rect = @@ -233,9 +233,9 @@ (x: 1830; y: 1424; w: 454; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template7FPoints: array[0..0] of TPoint = + Template7FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); @@ -262,9 +262,9 @@ (x: 2030; y: 1424; w: 20; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template8FPoints: array[0..0] of TPoint = + Template8FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template9Points: array[0..31] of TSDL_Rect = @@ -302,9 +302,9 @@ (x: 2080; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template9FPoints: array[0..0] of TPoint = + Template9FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template10Points: array[0..13] of TSDL_Rect = @@ -324,9 +324,9 @@ (x: 2182; y: 1424; w: 2; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template10FPoints: array[0..0] of TPoint = + Template10FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template11Points: array[0..9] of TSDL_Rect = @@ -342,9 +342,9 @@ (x: 1984; y: 1424; w: 136; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template11FPoints: array[0..0] of TPoint = + Template11FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template12Points: array[0..13] of TSDL_Rect = @@ -364,9 +364,9 @@ (x: 2088; y: 1424; w: 176; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template12FPoints: array[0..0] of TPoint = + Template12FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template13Points: array[0..15] of TSDL_Rect = @@ -388,9 +388,9 @@ (x: 1844; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template13FPoints: array[0..0] of TPoint = + Template13FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template14Points: array[0..13] of TSDL_Rect = @@ -410,9 +410,9 @@ (x: 2008; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template14FPoints: array[0..0] of TPoint = + Template14FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template15Points: array[0..23] of TSDL_Rect = @@ -442,9 +442,9 @@ (x: 2056; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template15FPoints: array[0..0] of TPoint = + Template15FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template16Points: array[0..28] of TSDL_Rect = @@ -479,9 +479,9 @@ (x: 2098; y: 1424; w: 52; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template16FPoints: array[0..0] of TPoint = + Template16FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template17Points: array[0..13] of TSDL_Rect = @@ -501,9 +501,9 @@ (x: 1998; y: 1424; w: 42; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template17FPoints: array[0..0] of TPoint = + Template17FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 1023; Y: 0) + (X: 1023; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); //////////////////// MIXING AND MATCHING ORIGINAL ////////////////////////////////////// const Template18Points: array[0..32] of TSDL_Rect = @@ -542,9 +542,9 @@ (x: 3598; y: 1424; w: 42; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template18FPoints: array[0..0] of TPoint = + Template18FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template19Points: array[0..44] of TSDL_Rect = @@ -595,9 +595,9 @@ (x: 3398; y: 1424; w: 52; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template19FPoints: array[0..0] of TPoint = + Template19FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template20Points: array[0..45] of TSDL_Rect = @@ -649,9 +649,9 @@ (x: 3456; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template20FPoints: array[0..0] of TPoint = + Template20FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template21Points: array[0..30] of TSDL_Rect = @@ -688,9 +688,9 @@ (x: 3258; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template21FPoints: array[0..0] of TPoint = + Template21FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template22Points: array[0..38] of TSDL_Rect = @@ -735,9 +735,9 @@ (x: 3244; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template22FPoints: array[0..0] of TPoint = + Template22FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template23Points: array[0..29] of TSDL_Rect = @@ -773,9 +773,9 @@ (x: 3438; y: 1424; w: 176; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template23FPoints: array[0..0] of TPoint = + Template23FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template24Points: array[0..23] of TSDL_Rect = @@ -805,9 +805,9 @@ (x: 3346; y: 1420; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template24FPoints: array[0..0] of TPoint = + Template24FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template25Points: array[0..19] of TSDL_Rect = @@ -833,9 +833,9 @@ (x: 3532; y: 1424; w: 2; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template25FPoints: array[0..0] of TPoint = + Template25FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); @@ -894,9 +894,9 @@ (x: 3480; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template26FPoints: array[0..0] of TPoint = + Template26FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template27Points: array[0..42] of TSDL_Rect = @@ -945,9 +945,9 @@ (x: 3556; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template27FPoints: array[0..0] of TPoint = + Template27FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template28Points: array[0..29] of TSDL_Rect = @@ -983,9 +983,9 @@ (x: 3308; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template28FPoints: array[0..0] of TPoint = + Template28FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template29Points: array[0..37] of TSDL_Rect = @@ -1029,9 +1029,9 @@ (x: 3094; y: 1424; w: 2; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template29FPoints: array[0..0] of TPoint = + Template29FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template30Points: array[0..30] of TSDL_Rect = @@ -1068,9 +1068,9 @@ (x: 3288; y: 1424; w: 176; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template30FPoints: array[0..0] of TPoint = + Template30FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template31Points: array[0..32] of TSDL_Rect = @@ -1109,9 +1109,9 @@ (x: 3584; y: 1424; w: 136; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template31FPoints: array[0..0] of TPoint = + Template31FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template32Points: array[0..29] of TSDL_Rect = @@ -1147,9 +1147,9 @@ (x: 3682; y: 1424; w: 2; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template32FPoints: array[0..0] of TPoint = + Template32FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template33Points: array[0..45] of TSDL_Rect = @@ -1201,9 +1201,9 @@ (x: 3480; y: 1424; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template33FPoints: array[0..0] of TPoint = + Template33FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template34Points: array[0..25] of TSDL_Rect = @@ -1235,9 +1235,9 @@ (x: 3230; y: 1424; w: 20; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template34FPoints: array[0..0] of TPoint = + Template34FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template35Points: array[0..48] of TSDL_Rect = @@ -1292,9 +1292,9 @@ (x: 3498; y: 1424; w: 52; h: 2), (x: NTPX; y: 0; w: 1; h: 1) ); - Template35FPoints: array[0..0] of TPoint = + Template35FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); ///////////////////////// CAVERNS /////////////////////////////////// @@ -1320,9 +1320,9 @@ (x: 576; y: 976; w: 16; h: 28), (x: NTPX; y: 0; w: 1; h: 1) ); - Template36FPoints: array[0..0] of TPoint = + Template36FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); ////////////////////////////// ... Silly ... //////////////////////////////// /// Ok. Tiy does not care for these. Perhaps they could be saved. @@ -1361,9 +1361,9 @@ (x: 2250; y: 1200; w: 25; h: 25), (x: NTPX; y: 0; w: 1; h: 1) ); - Template37FPoints: array[0..0] of TPoint = + Template37FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // attempt to make a series of moderate hills/valleys - was before I really figured out the whole probabilities thing const Template38Points: array[0..16] of TSDL_Rect = @@ -1386,9 +1386,9 @@ (x: 3700; y: 2100; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template38FPoints: array[0..0] of TPoint = + Template38FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // 8 tiny islands @@ -1435,9 +1435,9 @@ (x: 1430; y: 520; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template39FPoints: array[0..0] of TPoint = + Template39FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 512; Y: 0) + (X: 512; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); const Template40Points: array[0..7] of TSDL_Rect = ( @@ -1450,9 +1450,9 @@ (x: 900; y: 1050; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template40FPoints: array[0..0] of TPoint = + Template40FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 512; Y: 0) + (X: 512; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // Many islands const Template41Points: array[0..86] of TSDL_Rect = @@ -1545,9 +1545,9 @@ (x: 4050; y: 125; w: 50; h: 75), (x: NTPX; y: 0; w: 1; h: 1) ); - Template41FPoints: array[0..0] of TPoint = + Template41FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 2047; Y: 0) + (X: 2047; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // 2 tiny islands const Template42Points: array[0..13] of TSDL_Rect = @@ -1567,9 +1567,9 @@ (x: 1430; y: 520; w: 1; h: 1), (x: NTPX; y: 0; w: 1; h: 1) ); - Template42FPoints: array[0..0] of TPoint = + Template42FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 512; Y: 0) + (X: 512; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // Many islands const Template43Points: array[0..173] of TSDL_Rect = @@ -1749,9 +1749,9 @@ (x: 4050; y:2173; w: 50; h: 75), (x: NTPX; y:2048; w: 1; h: 1) ); - Template43FPoints: array[0..0] of TPoint = + Template43FPoints: array[0..{$IFDEF PAS2C}1{$ELSE}0{$ENDIF}] of TPoint = ( - (X: 4095; Y: 0) + (X: 4095; Y: 0){$IFDEF PAS2C},(X:0;Y:9){$ENDIF} ); // 3 large caverns @@ -1775,12 +1775,12 @@ ); Template44FPoints: array[0..5] of TSDL_Rect = ( - (X: 1; Y: 90; w: 0; h: 0), - (X: 1; Y: 500; w: 0; h: 0), - (X:4095; Y: 500; w: 0; h: 0), - (X: 1; Y:1200; w: 0; h: 0), - (X:4095; Y:1200; w: 0; h: 0), - (X: 1; Y:2010; w: 0; h: 0) + (x: 1; y: 90; w: 0; h: 0), + (x: 1; y: 500; w: 0; h: 0), + (x:4095; y: 500; w: 0; h: 0), + (x: 1; y:1200; w: 0; h: 0), + (x:4095; y:1200; w: 0; h: 0), + (x: 1; y:2010; w: 0; h: 0) ); // large caverns with an island @@ -1801,9 +1801,9 @@ ); Template45FPoints: array[0..2] of TSDL_Rect = ( - (X: 1; Y: 1; w: 0; h: 0), - (X: 1; Y:2047; w: 0; h: 0), - (X:1005; Y: 805; w: 0; h: 0) + (x: 1; y: 1; w: 0; h: 0), + (x: 1; y:2047; w: 0; h: 0), + (x:1005; y: 805; w: 0; h: 0) ); //////////////////////////////////////////////////////////////////////// @@ -1812,7 +1812,7 @@ (BasePoints: @Template0Points; BasePointsCount: Succ(High(Template0Points)); FillPoints: @Template0FPoints; - FillPointsCount: Succ(High(Template0FPoints)); + FillPointsCount: Succ(High(Template0FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1823,7 +1823,7 @@ (BasePoints: @Template1Points; BasePointsCount: Succ(High(Template1Points)); FillPoints: @Template1FPoints; - FillPointsCount: Succ(High(Template1FPoints)); + FillPointsCount: Succ(High(Template1FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1834,7 +1834,7 @@ (BasePoints: @Template2Points; BasePointsCount: Succ(High(Template2Points)); FillPoints: @Template2FPoints; - FillPointsCount: Succ(High(Template2FPoints)); + FillPointsCount: Succ(High(Template2FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1845,7 +1845,7 @@ (BasePoints: @Template3Points; BasePointsCount: Succ(High(Template3Points)); FillPoints: @Template3FPoints; - FillPointsCount: Succ(High(Template3FPoints)); + FillPointsCount: Succ(High(Template3FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1856,7 +1856,7 @@ (BasePoints: @Template4Points; BasePointsCount: Succ(High(Template4Points)); FillPoints: @Template4FPoints; - FillPointsCount: Succ(High(Template4FPoints)); + FillPointsCount: Succ(High(Template4FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1867,7 +1867,7 @@ (BasePoints: @Template5Points; BasePointsCount: Succ(High(Template5Points)); FillPoints: @Template5FPoints; - FillPointsCount: Succ(High(Template5FPoints)); + FillPointsCount: Succ(High(Template5FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1878,7 +1878,7 @@ (BasePoints: @Template6Points; BasePointsCount: Succ(High(Template6Points)); FillPoints: @Template6FPoints; - FillPointsCount: Succ(High(Template6FPoints)); + FillPointsCount: Succ(High(Template6FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1889,7 +1889,7 @@ (BasePoints: @Template7Points; BasePointsCount: Succ(High(Template7Points)); FillPoints: @Template7FPoints; - FillPointsCount: Succ(High(Template7FPoints)); + FillPointsCount: Succ(High(Template7FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 4; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1900,7 +1900,7 @@ (BasePoints: @Template8Points; BasePointsCount: Succ(High(Template8Points)); FillPoints: @Template8FPoints; - FillPointsCount: Succ(High(Template8FPoints)); + FillPointsCount: Succ(High(Template8FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1911,7 +1911,7 @@ (BasePoints: @Template9Points; BasePointsCount: Succ(High(Template9Points)); FillPoints: @Template9FPoints; - FillPointsCount: Succ(High(Template9FPoints)); + FillPointsCount: Succ(High(Template9FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 1; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1922,7 +1922,7 @@ (BasePoints: @Template10Points; BasePointsCount: Succ(High(Template10Points)); FillPoints: @Template10FPoints; - FillPointsCount: Succ(High(Template10FPoints)); + FillPointsCount: Succ(High(Template10FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1933,7 +1933,7 @@ (BasePoints: @Template11Points; BasePointsCount: Succ(High(Template11Points)); FillPoints: @Template11FPoints; - FillPointsCount: Succ(High(Template11FPoints)); + FillPointsCount: Succ(High(Template11FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 1; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1944,7 +1944,7 @@ (BasePoints: @Template12Points; BasePointsCount: Succ(High(Template12Points)); FillPoints: @Template12FPoints; - FillPointsCount: Succ(High(Template12FPoints)); + FillPointsCount: Succ(High(Template12FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1955,7 +1955,7 @@ (BasePoints: @Template13Points; BasePointsCount: Succ(High(Template13Points)); FillPoints: @Template13FPoints; - FillPointsCount: Succ(High(Template13FPoints)); + FillPointsCount: Succ(High(Template13FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1966,7 +1966,7 @@ (BasePoints: @Template14Points; BasePointsCount: Succ(High(Template14Points)); FillPoints: @Template14FPoints; - FillPointsCount: Succ(High(Template14FPoints)); + FillPointsCount: Succ(High(Template14FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1977,7 +1977,7 @@ (BasePoints: @Template15Points; BasePointsCount: Succ(High(Template15Points)); FillPoints: @Template15FPoints; - FillPointsCount: Succ(High(Template15FPoints)); + FillPointsCount: Succ(High(Template15FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1988,7 +1988,7 @@ (BasePoints: @Template16Points; BasePointsCount: Succ(High(Template16Points)); FillPoints: @Template16FPoints; - FillPointsCount: Succ(High(Template16FPoints)); + FillPointsCount: Succ(High(Template16FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 2848; @@ -1999,7 +1999,7 @@ (BasePoints: @Template17Points; BasePointsCount: Succ(High(Template17Points)); FillPoints: @Template17FPoints; - FillPointsCount: Succ(High(Template17FPoints)); + FillPointsCount: Succ(High(Template17FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 2848; @@ -2010,7 +2010,7 @@ (BasePoints: @Template18Points; BasePointsCount: Succ(High(Template18Points)); FillPoints: @Template18FPoints; - FillPointsCount: Succ(High(Template18FPoints)); + FillPointsCount: Succ(High(Template18FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2021,7 +2021,7 @@ (BasePoints: @Template19Points; BasePointsCount: Succ(High(Template19Points)); FillPoints: @Template19FPoints; - FillPointsCount: Succ(High(Template19FPoints)); + FillPointsCount: Succ(High(Template19FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2032,7 +2032,7 @@ (BasePoints: @Template20Points; BasePointsCount: Succ(High(Template20Points)); FillPoints: @Template20FPoints; - FillPointsCount: Succ(High(Template20FPoints)); + FillPointsCount: Succ(High(Template20FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2043,7 +2043,7 @@ (BasePoints: @Template21Points; BasePointsCount: Succ(High(Template21Points)); FillPoints: @Template21FPoints; - FillPointsCount: Succ(High(Template21FPoints)); + FillPointsCount: Succ(High(Template21FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2054,7 +2054,7 @@ (BasePoints: @Template22Points; BasePointsCount: Succ(High(Template22Points)); FillPoints: @Template22FPoints; - FillPointsCount: Succ(High(Template22FPoints)); + FillPointsCount: Succ(High(Template22FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2065,7 +2065,7 @@ (BasePoints: @Template23Points; BasePointsCount: Succ(High(Template23Points)); FillPoints: @Template23FPoints; - FillPointsCount: Succ(High(Template23FPoints)); + FillPointsCount: Succ(High(Template23FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2076,7 +2076,7 @@ (BasePoints: @Template24Points; BasePointsCount: Succ(High(Template24Points)); FillPoints: @Template24FPoints; - FillPointsCount: Succ(High(Template24FPoints)); + FillPointsCount: Succ(High(Template24FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2087,7 +2087,7 @@ (BasePoints: @Template25Points; BasePointsCount: Succ(High(Template25Points)); FillPoints: @Template25FPoints; - FillPointsCount: Succ(High(Template25FPoints)); + FillPointsCount: Succ(High(Template25FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 4; RandPassesCount: 4; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2098,7 +2098,7 @@ (BasePoints: @Template26Points; BasePointsCount: Succ(High(Template26Points)); FillPoints: @Template26FPoints; - FillPointsCount: Succ(High(Template26FPoints)); + FillPointsCount: Succ(High(Template26FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2109,7 +2109,7 @@ (BasePoints: @Template27Points; BasePointsCount: Succ(High(Template27Points)); FillPoints: @Template27FPoints; - FillPointsCount: Succ(High(Template27FPoints)); + FillPointsCount: Succ(High(Template27FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 1; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2120,7 +2120,7 @@ (BasePoints: @Template28Points; BasePointsCount: Succ(High(Template28Points)); FillPoints: @Template28FPoints; - FillPointsCount: Succ(High(Template28FPoints)); + FillPointsCount: Succ(High(Template28FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2131,7 +2131,7 @@ (BasePoints: @Template29Points; BasePointsCount: Succ(High(Template29Points)); FillPoints: @Template29FPoints; - FillPointsCount: Succ(High(Template29FPoints)); + FillPointsCount: Succ(High(Template29FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 1; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2142,7 +2142,7 @@ (BasePoints: @Template30Points; BasePointsCount: Succ(High(Template30Points)); FillPoints: @Template30FPoints; - FillPointsCount: Succ(High(Template30FPoints)); + FillPointsCount: Succ(High(Template30FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 8; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2153,7 +2153,7 @@ (BasePoints: @Template31Points; BasePointsCount: Succ(High(Template31Points)); FillPoints: @Template31FPoints; - FillPointsCount: Succ(High(Template31FPoints)); + FillPointsCount: Succ(High(Template31FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 5; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2164,7 +2164,7 @@ (BasePoints: @Template32Points; BasePointsCount: Succ(High(Template32Points)); FillPoints: @Template32FPoints; - FillPointsCount: Succ(High(Template32FPoints)); + FillPointsCount: Succ(High(Template32FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2175,7 +2175,7 @@ (BasePoints: @Template33Points; BasePointsCount: Succ(High(Template33Points)); FillPoints: @Template33FPoints; - FillPointsCount: Succ(High(Template33FPoints)); + FillPointsCount: Succ(High(Template33FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2186,7 +2186,7 @@ (BasePoints: @Template34Points; BasePointsCount: Succ(High(Template34Points)); FillPoints: @Template34FPoints; - FillPointsCount: Succ(High(Template34FPoints)); + FillPointsCount: Succ(High(Template34FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 6; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2197,7 +2197,7 @@ (BasePoints: @Template35Points; BasePointsCount: Succ(High(Template35Points)); FillPoints: @Template35FPoints; - FillPointsCount: Succ(High(Template35FPoints)); + FillPointsCount: Succ(High(Template35FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 7; TemplateHeight: 1424; TemplateWidth: 3900; @@ -2208,7 +2208,7 @@ (BasePoints: @Template36Points; BasePointsCount: Succ(High(Template36Points)); FillPoints: @Template36FPoints; - FillPointsCount: Succ(High(Template36FPoints)); + FillPointsCount: Succ(High(Template36FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 4; RandPassesCount: 12; TemplateHeight: 1024; TemplateWidth: 4096; @@ -2219,7 +2219,7 @@ (BasePoints: @Template37Points; BasePointsCount: Succ(High(Template37Points)); FillPoints: @Template37FPoints; - FillPointsCount: Succ(High(Template37FPoints)); + FillPointsCount: Succ(High(Template37FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 3; TemplateHeight: 2048; TemplateWidth: 4096; @@ -2230,7 +2230,7 @@ (BasePoints: @Template38Points; BasePointsCount: Succ(High(Template38Points)); FillPoints: @Template38FPoints; - FillPointsCount: Succ(High(Template38FPoints)); + FillPointsCount: Succ(High(Template38FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 4; RandPassesCount: 4; TemplateHeight: 2048; TemplateWidth: 4096; @@ -2241,7 +2241,7 @@ (BasePoints: @Template39Points; BasePointsCount: Succ(High(Template39Points)); FillPoints: @Template39FPoints; - FillPointsCount: Succ(High(Template39FPoints)); + FillPointsCount: Succ(High(Template39FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 3; TemplateHeight: 512; TemplateWidth: 1536; @@ -2252,7 +2252,7 @@ (BasePoints: @Template40Points; BasePointsCount: Succ(High(Template40Points)); FillPoints: @Template40FPoints; - FillPointsCount: Succ(High(Template40FPoints)); + FillPointsCount: Succ(High(Template40FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 3; TemplateHeight: 1024; TemplateWidth: 1024; @@ -2263,7 +2263,7 @@ (BasePoints: @Template41Points; BasePointsCount: Succ(High(Template41Points)); FillPoints: @Template41FPoints; - FillPointsCount: Succ(High(Template41FPoints)); + FillPointsCount: Succ(High(Template41FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 9; TemplateHeight: 2048; TemplateWidth: 4096; @@ -2274,7 +2274,7 @@ (BasePoints: @Template42Points; BasePointsCount: Succ(High(Template42Points)); FillPoints: @Template42FPoints; - FillPointsCount: Succ(High(Template42FPoints)); + FillPointsCount: Succ(High(Template42FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 3; RandPassesCount: 3; TemplateHeight: 512; TemplateWidth: 1536; @@ -2285,7 +2285,7 @@ (BasePoints: @Template43Points; BasePointsCount: Succ(High(Template43Points)); FillPoints: @Template43FPoints; - FillPointsCount: Succ(High(Template43FPoints)); + FillPointsCount: Succ(High(Template43FPoints)){$IFDEF PAS2C}-1{$ENDIF}; BezierizeCount: 2; RandPassesCount: 9; TemplateHeight: 4096; TemplateWidth: 4096; diff -r 2286a39140da -r 453917e94e55 hedgewars/uLandTexture.pas --- a/hedgewars/uLandTexture.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uLandTexture.pas Thu Nov 22 00:41:53 2012 +0100 @@ -39,10 +39,11 @@ tex: PTexture; end; -var LandTextures: array of array of TLandRecord; - tmpPixels: array [0..TEXSIZE - 1, 0..TEXSIZE - 1] of LongWord; - LANDTEXARW: LongWord; - LANDTEXARH: LongWord; +var + LandTextures : array of array of TLandRecord; + tmpPixels : array [0..TEXSIZE - 1, 0..TEXSIZE - 1] of LongWord; + LANDTEXARW : LongWord; + LANDTEXARH : LongWord; function Pixels(x, y: Longword): Pointer; var ty: Longword; @@ -198,7 +199,6 @@ LANDTEXARW:= (LAND_WIDTH div TEXSIZE) div 2; LANDTEXARH:= (LAND_HEIGHT div TEXSIZE) div 2; end; - SetLength(LandTextures, LANDTEXARW, LANDTEXARH); end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uLocale.pas diff -r 2286a39140da -r 453917e94e55 hedgewars/uMatrix.pas --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/uMatrix.pas Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,268 @@ +(* + * Hedgewars, a free turn based strategy game + * Copyright (c) 2004-2012 Andrey Korotaev + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + *) + +{$INCLUDE "options.inc"} + +unit uMatrix; + +interface + +uses uTypes {$IFNDEF PAS2C}, gl{$ENDIF}; + +const + MATRIX_MODELVIEW:Integer = 0; + MATRIX_PROJECTION:Integer = 1; + +procedure MatrixLoadIdentity(out Result: TMatrix4x4f); +procedure MatrixMultiply(out Result: TMatrix4x4f; const lhs, rhs: TMatrix4x4f); + +procedure hglMatrixMode(t: Integer); +procedure hglLoadIdentity(); +procedure hglPushMatrix(); +procedure hglPopMatrix(); +procedure hglMVP(var res : TMatrix4x4f); +procedure hglScalef(x: GLfloat; y: GLfloat; z: GLfloat); +procedure hglTranslatef(x: GLfloat; y: GLfloat; z: GLfloat); +procedure hglRotatef(a:GLfloat; x:GLfloat; y:GLfloat; z:GLfloat); +procedure initModule(); +procedure freeModule(); + +implementation + +const + MATRIX_STACK_SIZE = 10; + +type + TMatrixStack = record + top:Integer; + stack: array[0..9] of TMatrix4x4f; + end; +var + MatrixStacks : array[0..1] of TMatrixStack; + CurMatrix: integer; + +procedure MatrixLoadIdentity(out Result: TMatrix4x4f); +begin + Result[0,0]:= 1.0; Result[1,0]:=0.0; Result[2,0]:=0.0; Result[3,0]:=0.0; + Result[0,1]:= 0.0; Result[1,1]:=1.0; Result[2,1]:=0.0; Result[3,1]:=0.0; + Result[0,2]:= 0.0; Result[1,2]:=0.0; Result[2,2]:=1.0; Result[3,2]:=0.0; + Result[0,3]:= 0.0; Result[1,3]:=0.0; Result[2,3]:=0.0; Result[3,3]:=1.0; +end; + +procedure hglMatrixMode(t: Integer); +begin + CurMatrix := t; +end; + +procedure hglLoadIdentity(); +begin + MatrixLoadIdentity(MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top]); +end; + +procedure hglScalef(x: GLfloat; y: GLfloat; z: GLfloat); +var + m:TMatrix4x4f; + t:TMatrix4x4f; +begin + m[0,0]:=x;m[1,0]:=0;m[2,0]:=0;m[3,0]:=0; + m[0,1]:=0;m[1,1]:=y;m[2,1]:=0;m[3,1]:=0; + m[0,2]:=0;m[1,2]:=0;m[2,2]:=z;m[3,2]:=0; + m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1; + + MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m); + MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t; +end; + +procedure hglTranslatef(x: GLfloat; y: GLfloat; z: GLfloat); +var + m:TMatrix4x4f; + t:TMatrix4x4f; +begin + m[0,0]:=1;m[1,0]:=0;m[2,0]:=0;m[3,0]:=x; + m[0,1]:=0;m[1,1]:=1;m[2,1]:=0;m[3,1]:=y; + m[0,2]:=0;m[1,2]:=0;m[2,2]:=1;m[3,2]:=z; + m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1; + + MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m); + MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t; +end; + +procedure hglRotatef(a:GLfloat; x:GLfloat; y:GLfloat; z:GLfloat); +var + m:TMatrix4x4f; + t:TMatrix4x4f; + c:GLfloat; + s:GLfloat; + xn, yn, zn:GLfloat; + l:GLfloat; +begin + a:=a * 3.14159265368 / 180; + c:=cos(a); + s:=sin(a); + + l := 1.0 / sqrt(x * x + y * y + z * z); + xn := x * l; + yn := y * l; + zn := z * l; + + m[0,0]:=c + xn * xn * (1 - c); + m[1,0]:=xn * yn * (1 - c) - zn * s; + m[2,0]:=xn * zn * (1 - c) + yn * s; + m[3,0]:=0; + + + m[0,1]:=yn * xn * (1 - c) + zn * s; + m[1,1]:=c + yn * yn * (1 - c); + m[2,1]:=yn * zn * (1 - c) - xn * s; + m[3,1]:=0; + + m[0,2]:=zn * xn * (1 - c) - yn * s; + m[1,2]:=zn * yn * (1 - c) + xn * s; + m[2,2]:=c + zn * zn * (1 - c); + m[3,2]:=0; + + m[0,3]:=0;m[1,3]:=0;m[2,3]:=0;m[3,3]:=1; + + MatrixMultiply(t, MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top], m); + MatrixStacks[CurMatrix].stack[MatrixStacks[CurMatrix].top] := t; +end; + +procedure hglMVP(var res: TMatrix4x4f); +begin + MatrixMultiply(res, + MatrixStacks[MATRIX_PROJECTION].stack[MatrixStacks[MATRIX_PROJECTION].top], + MatrixStacks[MATRIX_MODELVIEW].stack[MatrixStacks[MATRIX_MODELVIEW].top]); +end; + +procedure hglPushMatrix(); +var + t: Integer; +begin + t := MatrixStacks[CurMatrix].top; + MatrixStacks[CurMatrix].stack[t + 1] := MatrixStacks[CurMatrix].stack[t]; + inc(t); + MatrixStacks[CurMatrix].top := t; +end; + +procedure hglPopMatrix(); +var + t: Integer; +begin + t := MatrixStacks[CurMatrix].top; + dec(t); + MatrixStacks[CurMatrix].top := t; +end; + +procedure initModule(); +begin + MatrixStacks[MATRIX_MODELVIEW].top := 0; + MatrixStacks[MATRIX_Projection].top := 0; + MatrixLoadIdentity(MatrixStacks[MATRIX_MODELVIEW].stack[0]); + MatrixLoadIdentity(MatrixStacks[MATRIX_PROJECTION].stack[0]); +end; + +procedure freeModule(); +begin +end; + +procedure MatrixMultiply(out Result: TMatrix4x4f; const lhs, rhs: TMatrix4x4f); +var + test: TMatrix4x4f; + i, j: Integer; + error: boolean; +begin + Result[0,0]:=lhs[0,0]*rhs[0,0] + lhs[1,0]*rhs[0,1] + lhs[2,0]*rhs[0,2] + lhs[3,0]*rhs[0,3]; + Result[0,1]:=lhs[0,1]*rhs[0,0] + lhs[1,1]*rhs[0,1] + lhs[2,1]*rhs[0,2] + lhs[3,1]*rhs[0,3]; + Result[0,2]:=lhs[0,2]*rhs[0,0] + lhs[1,2]*rhs[0,1] + lhs[2,2]*rhs[0,2] + lhs[3,2]*rhs[0,3]; + Result[0,3]:=lhs[0,3]*rhs[0,0] + lhs[1,3]*rhs[0,1] + lhs[2,3]*rhs[0,2] + lhs[3,3]*rhs[0,3]; + + Result[1,0]:=lhs[0,0]*rhs[1,0] + lhs[1,0]*rhs[1,1] + lhs[2,0]*rhs[1,2] + lhs[3,0]*rhs[1,3]; + Result[1,1]:=lhs[0,1]*rhs[1,0] + lhs[1,1]*rhs[1,1] + lhs[2,1]*rhs[1,2] + lhs[3,1]*rhs[1,3]; + Result[1,2]:=lhs[0,2]*rhs[1,0] + lhs[1,2]*rhs[1,1] + lhs[2,2]*rhs[1,2] + lhs[3,2]*rhs[1,3]; + Result[1,3]:=lhs[0,3]*rhs[1,0] + lhs[1,3]*rhs[1,1] + lhs[2,3]*rhs[1,2] + lhs[3,3]*rhs[1,3]; + + Result[2,0]:=lhs[0,0]*rhs[2,0] + lhs[1,0]*rhs[2,1] + lhs[2,0]*rhs[2,2] + lhs[3,0]*rhs[2,3]; + Result[2,1]:=lhs[0,1]*rhs[2,0] + lhs[1,1]*rhs[2,1] + lhs[2,1]*rhs[2,2] + lhs[3,1]*rhs[2,3]; + Result[2,2]:=lhs[0,2]*rhs[2,0] + lhs[1,2]*rhs[2,1] + lhs[2,2]*rhs[2,2] + lhs[3,2]*rhs[2,3]; + Result[2,3]:=lhs[0,3]*rhs[2,0] + lhs[1,3]*rhs[2,1] + lhs[2,3]*rhs[2,2] + lhs[3,3]*rhs[2,3]; + + Result[3,0]:=lhs[0,0]*rhs[3,0] + lhs[1,0]*rhs[3,1] + lhs[2,0]*rhs[3,2] + lhs[3,0]*rhs[3,3]; + Result[3,1]:=lhs[0,1]*rhs[3,0] + lhs[1,1]*rhs[3,1] + lhs[2,1]*rhs[3,2] + lhs[3,1]*rhs[3,3]; + Result[3,2]:=lhs[0,2]*rhs[3,0] + lhs[1,2]*rhs[3,1] + lhs[2,2]*rhs[3,2] + lhs[3,2]*rhs[3,3]; + Result[3,3]:=lhs[0,3]*rhs[3,0] + lhs[1,3]*rhs[3,1] + lhs[2,3]*rhs[3,2] + lhs[3,3]*rhs[3,3]; + +{ + Result[0,0]:=lhs[0,0]*rhs[0,0] + lhs[1,0]*rhs[0,1] + lhs[2,0]*rhs[0,2] + lhs[3,0]*rhs[0,3]; + Result[0,1]:=lhs[0,0]*rhs[1,0] + lhs[1,0]*rhs[1,1] + lhs[2,0]*rhs[1,2] + lhs[3,0]*rhs[1,3]; + Result[0,2]:=lhs[0,0]*rhs[2,0] + lhs[1,0]*rhs[2,1] + lhs[2,0]*rhs[2,2] + lhs[3,0]*rhs[2,3]; + Result[0,3]:=lhs[0,0]*rhs[3,0] + lhs[1,0]*rhs[3,1] + lhs[2,0]*rhs[3,2] + lhs[3,0]*rhs[3,3]; + + Result[1,0]:=lhs[0,1]*rhs[0,0] + lhs[1,1]*rhs[0,1] + lhs[2,1]*rhs[0,2] + lhs[3,1]*rhs[0,3]; + Result[1,1]:=lhs[0,1]*rhs[1,0] + lhs[1,1]*rhs[1,1] + lhs[2,1]*rhs[1,2] + lhs[3,1]*rhs[1,3]; + Result[1,2]:=lhs[0,1]*rhs[2,0] + lhs[1,1]*rhs[2,1] + lhs[2,1]*rhs[2,2] + lhs[3,1]*rhs[2,3]; + Result[1,3]:=lhs[0,1]*rhs[3,0] + lhs[1,1]*rhs[3,1] + lhs[2,1]*rhs[3,2] + lhs[3,1]*rhs[3,3]; + + Result[2,0]:=lhs[0,2]*rhs[0,0] + lhs[1,2]*rhs[0,1] + lhs[2,2]*rhs[0,2] + lhs[3,2]*rhs[0,3]; + Result[2,1]:=lhs[0,2]*rhs[1,0] + lhs[1,2]*rhs[1,1] + lhs[2,2]*rhs[1,2] + lhs[3,2]*rhs[1,3]; + Result[2,2]:=lhs[0,2]*rhs[2,0] + lhs[1,2]*rhs[2,1] + lhs[2,2]*rhs[2,2] + lhs[3,2]*rhs[2,3]; + Result[2,3]:=lhs[0,2]*rhs[3,0] + lhs[1,2]*rhs[3,1] + lhs[2,2]*rhs[3,2] + lhs[3,2]*rhs[3,3]; + + Result[3,0]:=lhs[0,3]*rhs[0,0] + lhs[1,3]*rhs[0,1] + lhs[2,3]*rhs[0,2] + lhs[3,3]*rhs[0,3]; + Result[3,1]:=lhs[0,3]*rhs[1,0] + lhs[1,3]*rhs[1,1] + lhs[2,3]*rhs[1,2] + lhs[3,3]*rhs[1,3]; + Result[3,2]:=lhs[0,3]*rhs[2,0] + lhs[1,3]*rhs[2,1] + lhs[2,3]*rhs[2,2] + lhs[3,3]*rhs[2,3]; + Result[3,3]:=lhs[0,3]*rhs[3,0] + lhs[1,3]*rhs[3,1] + lhs[2,3]*rhs[3,2] + lhs[3,3]*rhs[3,3]; +} + + {$IFNDEF PAS2C} + glPushMatrix; + glLoadMatrixf(@lhs[0, 0]); + glMultMatrixf(@rhs[0, 0]); + glGetFloatv(GL_MODELVIEW_MATRIX, @test[0, 0]); + glPopMatrix; + + error:=false; + for i:=0 to 3 do + for j:=0 to 3 do + if Abs(test[i, j] - Result[i, j]) > 0.000001 then + error:=true; + + if error then + begin + writeln('shall:'); + for i:=0 to 3 do + begin + for j:=0 to 3 do + write(test[i, j]); + writeln; + end; + + writeln('is:'); + for i:=0 to 3 do + begin + for j:=0 to 3 do + write(Result[i, j]); + writeln; + end; + halt(0); + end; + {$ENDIF} + +end; + + +end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uMisc.pas --- a/hedgewars/uMisc.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uMisc.pas Thu Nov 22 00:41:53 2012 +0100 @@ -49,7 +49,7 @@ size: QWord; end; -var conversionFormat: PSDL_PixelFormat; +var conversionFormat : PSDL_PixelFormat; procedure movecursor(dx, dy: LongInt); var x, y: LongInt; @@ -68,7 +68,7 @@ var i: LongInt; png_ptr: ^png_struct; info_ptr: ^png_info; - f: file; + f: File; image: PScreenshot; begin image:= PScreenshot(screenshot); @@ -141,6 +141,7 @@ ); image: PScreenshot; size: QWord; + writeResult:LongInt; begin image:= PScreenshot(screenshot); @@ -168,8 +169,8 @@ Rewrite(f, 1); if IOResult = 0 then begin - BlockWrite(f, head, sizeof(head)); - BlockWrite(f, image^.buffer^, size); + BlockWrite(f, head, sizeof(head), writeResult); + BlockWrite(f, image^.buffer^, size, writeResult); Close(f); end else @@ -275,6 +276,7 @@ var convertedSurf: PSDL_Surface; begin doSurfaceConversion:= tmpsurf; +{$IFNDEF WEBGL} if ((tmpsurf^.format^.bitsperpixel = 32) and (tmpsurf^.format^.rshift > tmpsurf^.format^.bshift)) or (tmpsurf^.format^.bitsperpixel = 24) then begin @@ -282,6 +284,7 @@ SDL_FreeSurface(tmpsurf); doSurfaceConversion:= convertedSurf; end; +{$ENDIF} end; {$IFDEF SDL13} @@ -314,4 +317,4 @@ SDL_FreeFormat(conversionFormat); end; -end. +end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uMobile.pas --- a/hedgewars/uMobile.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uMobile.pas Thu Nov 22 00:41:53 2012 +0100 @@ -73,7 +73,7 @@ end; // this function should make the device vibrate in some way -procedure PerformRumble; inline; +procedure performRumble; inline; {$IFDEF IPHONEOS}const kSystemSoundID_Vibrate = $00000FFF;{$ENDIF} begin // do not vibrate while synchronising a demo/save diff -r 2286a39140da -r 453917e94e55 hedgewars/uRandom.pas --- a/hedgewars/uRandom.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uRandom.pas Thu Nov 22 00:41:53 2012 +0100 @@ -31,7 +31,7 @@ uses uFloat; procedure SetRandomSeed(Seed: shortstring); // Sets the seed that should be used for generating pseudo-random values. -function GetRandomf: hwFloat; overload; // Returns a pseudo-random hwFloat. +function GetRandomf: hwFloat; // Returns a pseudo-random hwFloat. function GetRandom(m: LongWord): LongWord; overload; inline; // Returns a positive pseudo-random integer smaller than m. procedure AddRandomness(r: LongWord); inline; function rndSign(num: hwFloat): hwFloat; // Returns num with a random chance of having a inverted sign. @@ -45,10 +45,11 @@ procedure AddRandomness(r: LongWord); inline; begin n:= (n + 1) and $3F; -cirbuf[n]:= cirbuf[n] xor r + cirbuf[n]:= cirbuf[n] xor r; end; function GetNext: Longword; inline; +var s : string; begin n:= (n + 1) and $3F; cirbuf[n]:= @@ -56,7 +57,8 @@ cirbuf[(n + 9) and $3F]) {n - 55 mod 64} and $7FFFFFFF; {mod 2^31} -GetNext:= cirbuf[n] + GetNext:= cirbuf[n]; + str(GetNext, s); end; procedure SetRandomSeed(Seed: shortstring); @@ -74,7 +76,7 @@ cirbuf[i]:= $A98765 + 68; // odd number for i:= 0 to 1023 do - GetNext + GetNext; end; function GetRandomf: hwFloat; @@ -84,7 +86,7 @@ GetRandomf.QWordValue:= GetNext end; -function GetRandom(m: LongWord): LongWord; inline; +function GetRandom(m: LongWord): LongWord; overload; inline; begin GetNext; GetRandom:= GetNext mod m diff -r 2286a39140da -r 453917e94e55 hedgewars/uRender.pas --- a/hedgewars/uRender.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uRender.pas Thu Nov 22 00:41:53 2012 +0100 @@ -17,12 +17,13 @@ *) {$INCLUDE "options.inc"} +{$IF GLunit = GL}{$DEFINE GLunit:=GL,GLext}{$ENDIF} unit uRender; interface -uses SDLh, uTypes, GLunit, uConsts; +uses SDLh, uTypes, GLunit, uConsts, uStore, uMatrix; procedure DrawSprite (Sprite: TSprite; X, Y, Frame: LongInt); procedure DrawSprite (Sprite: TSprite; X, Y, FrameX, FrameY: LongInt); @@ -51,7 +52,6 @@ procedure Tint (r, g, b, a: Byte); inline; procedure Tint (c: Longword); inline; - implementation uses uVariables; @@ -68,7 +68,7 @@ begin DrawTextureFromRect(X, Y, r^.w, r^.h, r, SourceTexture) end; - +{ procedure DrawTextureFromRect(X, Y, W, H: LongInt; r: PSDL_Rect; SourceTexture: PTexture); var rr: TSDL_Rect; _l, _r, _t, _b: real; @@ -115,6 +115,63 @@ glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]); +glDrawArrays(GL_TRIANGLE_FAN, 0, High(VertexBuffer) - Low(VertexBuffer) + 1); +end; +} + +procedure DrawTextureFromRect(X, Y, W, H: LongInt; r: PSDL_Rect; SourceTexture: PTexture); +var + rr: TSDL_Rect; + VertexBuffer, TextureBuffer: array [0..3] of TVertex2f; + //VertexBuffer, TextureBuffer: TVertexRect; + _l, _r, _t, _b: GLfloat; +begin +if (SourceTexture^.h = 0) or (SourceTexture^.w = 0) then + exit; + +// do not draw anything outside the visible screen space (first check fixes some sprite drawing, e.g. hedgehogs) +if (abs(X) > W) and ((abs(X + W / 2) - W / 2) > cScreenWidth / cScaleFactor) then + exit; +if (abs(Y) > H) and ((abs(Y + H / 2 - (0.5 * cScreenHeight)) - H / 2) > cScreenHeight / cScaleFactor) then + exit; + +rr.x:= X; +rr.y:= Y; +rr.w:= W; +rr.h:= H; + +_l:= r^.x / SourceTexture^.w * SourceTexture^.rx; +_r:= (r^.x + r^.w) / SourceTexture^.w * SourceTexture^.rx; +_t:= r^.y / SourceTexture^.h * SourceTexture^.ry; +_b:= (r^.y + r^.h) / SourceTexture^.h * SourceTexture^.ry; + +glBindTexture(GL_TEXTURE_2D, SourceTexture^.id); + +VertexBuffer[0].X:= X; +VertexBuffer[0].Y:= Y; +VertexBuffer[1].X:= rr.w + X; +VertexBuffer[1].Y:= Y; +VertexBuffer[2].X:= rr.w + X; +VertexBuffer[2].Y:= rr.h + Y; +VertexBuffer[3].X:= X; +VertexBuffer[3].Y:= rr.h + Y; + +TextureBuffer[0].X:= _l; +TextureBuffer[0].Y:= _t; +TextureBuffer[1].X:= _r; +TextureBuffer[1].Y:= _t; +TextureBuffer[2].X:= _r; +TextureBuffer[2].Y:= _b; +TextureBuffer[3].X:= _l; +TextureBuffer[3].Y:= _b; + +SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); +SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer)); + +{$IFDEF GL2} +UpdateModelviewProjection; +{$ENDIF} + glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); end; @@ -126,17 +183,30 @@ procedure DrawTexture(X, Y: LongInt; Texture: PTexture; Scale: GLfloat); begin +{$IFDEF GL2} +hglPushMatrix; +hglTranslatef(X, Y, 0); +hglScalef(Scale, Scale, 1); +{$ELSE} glPushMatrix; glTranslatef(X, Y, 0); glScalef(Scale, Scale, 1); +{$ENDIF} glBindTexture(GL_TEXTURE_2D, Texture^.id); -glVertexPointer(2, GL_FLOAT, 0, @Texture^.vb); -glTexCoordPointer(2, GL_FLOAT, 0, @Texture^.tb); +SetVertexPointer(@Texture^.vb, Length(Texture^.vb)); +SetTexCoordPointer(@Texture^.tb, Length(Texture^.vb)); + +{$IFDEF GL2} +UpdateModelviewProjection; glDrawArrays(GL_TRIANGLE_FAN, 0, Length(Texture^.vb)); +hglPopMatrix; +{$ELSE} +glDrawArrays(GL_TRIANGLE_FAN, 0, Length(Texture^.vb)); +glPopMatrix; +{$ENDIF} -glPopMatrix end; procedure DrawTextureF(Texture: PTexture; Scale: GLfloat; X, Y, Frame, Dir, w, h: LongInt); @@ -155,14 +225,25 @@ if (abs(Y) > H) and ((abs(Y + OffsetY - (0.5 * cScreenHeight)) - W / 2) * cScaleFactor > cScreenHeight) then exit; +{$IFDEF GL2} +hglPushMatrix; +hglTranslatef(X, Y, 0); +{$ELSE} glPushMatrix; glTranslatef(X, Y, 0); +{$ENDIF} + if Dir = 0 then Dir:= 1; +{$IFDEF GL2} +hglRotatef(Angle, 0, 0, Dir); +hglTranslatef(Dir*OffsetX, OffsetY, 0); +hglScalef(Scale, Scale, 1); +{$ELSE} glRotatef(Angle, 0, 0, Dir); - glTranslatef(Dir*OffsetX, OffsetY, 0); glScalef(Scale, Scale, 1); +{$ENDIF} // Any reason for this call? And why only in t direction, not s? //glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); @@ -197,11 +278,21 @@ TextureBuffer[3].X:= fl; TextureBuffer[3].Y:= fb; -glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); -glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]); +SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); +SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer)); + +{$IFDEF GL2} +UpdateModelviewProjection; +{$ENDIF} + glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); -glPopMatrix +{$IFDEF GL2} +hglPopMatrix; +{$ELSE} +glPopMatrix; +{$ENDIF} + end; procedure DrawSpriteRotated(Sprite: TSprite; X, Y, Dir: LongInt; Angle: real); @@ -214,19 +305,42 @@ procedure DrawSpriteRotatedF(Sprite: TSprite; X, Y, Frame, Dir: LongInt; Angle: real); begin + +{$IFDEF GL2} +hglPushMatrix; +hglTranslatef(X, Y, 0); +{$ELSE} glPushMatrix; glTranslatef(X, Y, 0); +{$ENDIF} if Dir < 0 then +{$IFDEF GL2} + hglRotatef(Angle, 0, 0, -1) +{$ELSE} glRotatef(Angle, 0, 0, -1) +{$ENDIF} else +{$IFDEF GL2} + hglRotatef(Angle, 0, 0, 1); +{$ELSE} glRotatef(Angle, 0, 0, 1); +{$ENDIF} if Dir < 0 then +{$IFDEF GL2} + hglScalef(-1.0, 1.0, 1.0); +{$ELSE} glScalef(-1.0, 1.0, 1.0); +{$ENDIF} DrawSprite(Sprite, -SpritesData[Sprite].Width div 2, -SpritesData[Sprite].Height div 2, Frame); -glPopMatrix +{$IFDEF GL2} +hglPopMatrix; +{$ELSE} +glPopMatrix; +{$ENDIF} + end; procedure DrawTextureRotated(Texture: PTexture; hw, hh, X, Y, Dir: LongInt; Angle: real); @@ -238,17 +352,29 @@ if (abs(Y) > 2 * hh) and ((abs(Y - 0.5 * cScreenHeight) - hh) > cScreenHeight / cScaleFactor) then exit; +{$IFDEF GL2} +hglPushMatrix; +hglTranslatef(X, Y, 0); +{$ELSE} glPushMatrix; glTranslatef(X, Y, 0); +{$ENDIF} if Dir < 0 then begin hw:= - hw; +{$IFDEF GL2} + hglRotatef(Angle, 0, 0, -1); +{$ELSE} glRotatef(Angle, 0, 0, -1); +{$ENDIF} end else - glRotatef(Angle, 0, 0, 1); - +{$IFDEF GL2} + hglRotatef(Angle, 0, 0, 1); +{$ELSE} + glRotatef(Angle, 0, 0, 1); +{$ENDIF} glBindTexture(GL_TEXTURE_2D, Texture^.id); @@ -261,11 +387,21 @@ VertexBuffer[3].X:= -hw; VertexBuffer[3].Y:= hh; -glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); -glTexCoordPointer(2, GL_FLOAT, 0, @Texture^.tb); +SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); +SetTexCoordPointer(@Texture^.tb, Length(VertexBuffer)); + +{$IFDEF GL2} +UpdateModelviewProjection; +{$ENDIF} + glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); -glPopMatrix +{$IFDEF GL2} +hglPopMatrix; +{$ELSE} +glPopMatrix; +{$ENDIF} + end; procedure DrawSprite(Sprite: TSprite; X, Y, Frame: LongInt); @@ -324,10 +460,11 @@ end; procedure DrawLine(X0, Y0, X1, Y1, Width: Single; r, g, b, a: Byte); -var VertexBuffer: array [0..3] of TVertex2f; +var VertexBuffer: array [0..1] of TVertex2f; begin + glEnable(GL_LINE_SMOOTH); +{$IFNDEF GL2} glDisable(GL_TEXTURE_2D); - glEnable(GL_LINE_SMOOTH); glPushMatrix; glTranslatef(WorldDx, WorldDy, 0); @@ -339,13 +476,37 @@ VertexBuffer[1].X:= X1; VertexBuffer[1].Y:= Y1; - glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); + SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); glDrawArrays(GL_LINES, 0, Length(VertexBuffer)); Tint($FF, $FF, $FF, $FF); glPopMatrix; glEnable(GL_TEXTURE_2D); + +{$ELSE} + EnableTexture(False); + + hglPushMatrix; + hglTranslatef(WorldDx, WorldDy, 0); + glLineWidth(Width); + + UpdateModelviewProjection; + + Tint(r, g, b, a); + VertexBuffer[0].X:= X0; + VertexBuffer[0].Y:= Y0; + VertexBuffer[1].X:= X1; + VertexBuffer[1].Y:= Y1; + + SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); + glDrawArrays(GL_LINES, 0, Length(VertexBuffer)); + Tint($FF, $FF, $FF, $FF); + + hglPopMatrix; + EnableTexture(True); + +{$ENDIF} glDisable(GL_LINE_SMOOTH); end; @@ -353,12 +514,17 @@ var VertexBuffer: array [0..3] of TVertex2f; begin // do not draw anything outside the visible screen space (first check fixes some sprite drawing, e.g. hedgehogs) + if (abs(r.x) > r.w) and ((abs(r.x + r.w / 2) - r.w / 2) * cScaleFactor > cScreenWidth) then exit; if (abs(r.y) > r.h) and ((abs(r.y + r.h / 2 - (0.5 * cScreenHeight)) - r.h / 2) * cScaleFactor > cScreenHeight) then exit; +{$IFDEF GL2} +EnableTexture(False); +{$ELSE} glDisable(GL_TEXTURE_2D); +{$ENDIF} Tint($00, $00, $00, $80); @@ -371,11 +537,17 @@ VertexBuffer[3].X:= r.x; VertexBuffer[3].Y:= r.y + r.h; -glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); +SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); Tint($FF, $FF, $FF, $FF); + +{$IFDEF GL2} +EnableTexture(True); +{$ELSE} glEnable(GL_TEXTURE_2D) +{$ENDIF} + end; procedure DrawCircle(X, Y, Radius, Width: LongInt; r, g, b, a: Byte); @@ -394,6 +566,9 @@ CircleVertex[i].X := X + Radius*cos(i*pi/30); CircleVertex[i].Y := Y + Radius*sin(i*pi/30); end; + +{$IFNDEF GL2} + glDisable(GL_TEXTURE_2D); glEnable(GL_LINE_SMOOTH); glPushMatrix; @@ -403,6 +578,18 @@ glPopMatrix; glEnable(GL_TEXTURE_2D); glDisable(GL_LINE_SMOOTH); + +{$ELSE} + EnableTexture(False); + glEnable(GL_LINE_SMOOTH); + hglPushMatrix; + glLineWidth(Width); + SetVertexPointer(@CircleVertex[0], 60); + glDrawArrays(GL_LINE_LOOP, 0, 60); + hglPopMatrix; + EnableTexture(True); + glDisable(GL_LINE_SMOOTH); +{$ENDIF} end; @@ -435,10 +622,15 @@ r:= (Step + 1) * 32 / HHTexture^.w end; - +{$IFDEF GL2} + hglPushMatrix(); + hglTranslatef(X, Y, 0); + hglRotatef(Angle, 0, 0, 1); +{$ELSE} glPushMatrix(); glTranslatef(X, Y, 0); glRotatef(Angle, 0, 0, 1); +{$ENDIF} glBindTexture(GL_TEXTURE_2D, HHTexture^.id); @@ -451,11 +643,20 @@ TextureBuffer[3].X:= l; TextureBuffer[3].Y:= b; - glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); - glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]); + SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); + SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer)); + +{$IFDEF GL2} + UpdateModelviewProjection; +{$ENDIF} + glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); - glPopMatrix +{$IFDEF GL2} + hglPopMatrix; +{$ELSE} + glPopMatrix; +{$ENDIF} end; procedure DrawScreenWidget(widget: POnScreenWidget); @@ -501,12 +702,14 @@ end; {$ELSE} begin -widget:= widget; // avoid hint +{widget:= widget; // avoid hint} {$ENDIF} end; procedure Tint(r, g, b, a: Byte); inline; -var nc, tw: Longword; +var + nc, tw: Longword; + scale:Real = 1.0/255.0; begin nc:= (a shl 24) or (b shl 16) or (g shl 8) or r; @@ -523,7 +726,12 @@ b:= tw end; + {$IFDEF GL2} + glUniform4f(uMainTintLocation, r*scale, g*scale, b*scale, a*scale); + //glColor4ub(r, g, b, a); + {$ELSE} glColor4ub(r, g, b, a); + {$ENDIF} lastTint:= nc; end; @@ -532,4 +740,5 @@ Tint(((c shr 24) and $FF), ((c shr 16) and $FF), (c shr 8) and $FF, (c and $FF)) end; + end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uRenderUtils.pas --- a/hedgewars/uRenderUtils.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uRenderUtils.pas Thu Nov 22 00:41:53 2012 +0100 @@ -68,7 +68,7 @@ r.y:= rect^.y + 2; r.w:= rect^.w - 2; r.h:= rect^.h - 4; - SDL_FillRect(Surface, @r, FillColor) + SDL_FillRect(Surface, @r, FillColor); end; (* function WriteInRoundRect(Surface: PSDL_Surface; X, Y: LongInt; Color: LongWord; Font: THWFont; s: ansistring): TSDL_Rect; @@ -115,6 +115,7 @@ pixels: PLongWordArray; begin TryDo(Surface^.format^.BytesPerPixel = 4, 'flipSurface failed, expecting 32 bit surface', true); + SDL_LockSurface(Surface); pixels:= Surface^.pixels; if Vertical then for y := 0 to (Surface^.h div 2) - 1 do @@ -136,6 +137,7 @@ pixels^[i]:= pixels^[j]; pixels^[j]:= tmpPixel; end; + SDL_UnlockSurface(Surface); end; procedure copyToXY(src, dest: PSDL_Surface; destX, destY: LongInt); inline; @@ -150,6 +152,10 @@ begin maxDest:= (dest^.pitch div 4) * dest^.h; maxSrc:= (src^.pitch div 4) * src^.h; + + SDL_LockSurface(src); + SDL_LockSurface(dest); + srcPixels:= src^.pixels; destPixels:= dest^.pixels; @@ -169,6 +175,9 @@ destPixels^[i]:= SDL_MapRGBA(dest^.format, r0, g0, b0, a0); end; end; + + SDL_UnlockSurface(src); + SDL_UnlockSurface(dest); end; procedure DrawSprite2Surf(sprite: TSprite; dest: PSDL_Surface; x,y: LongInt); inline; @@ -199,6 +208,9 @@ begin //max:= (dest^.pitch div 4) * dest^.h; yMax:= dest^.pitch div 4; + + SDL_LockSurface(dest); + destPixels:= dest^.pixels; dx:= abs(x1-x0); @@ -225,7 +237,8 @@ err:= err + dx; y0:=y0+sy end; - end; + end; + SDL_UnlockSurface(dest); end; procedure copyRotatedSurface(src, dest: PSDL_Surface); // this is necessary since width/height are read only in SDL, apparently @@ -235,6 +248,9 @@ TryDo(src^.format^.BytesPerPixel = 4, 'rotateSurface failed, expecting 32 bit surface', true); TryDo(dest^.format^.BytesPerPixel = 4, 'rotateSurface failed, expecting 32 bit surface', true); + SDL_LockSurface(src); + SDL_LockSurface(dest); + srcPixels:= src^.pixels; destPixels:= dest^.pixels; @@ -246,6 +262,10 @@ destPixels^[j]:= srcPixels^[i]; inc(j) end; + + SDL_UnlockSurface(src); + SDL_UnlockSurface(dest); + end; function RenderStringTex(s: ansistring; Color: Longword; font: THWFont): PTexture; @@ -282,11 +302,11 @@ var textWidth, textHeight, x, y, w, h, i, j, pos, prevpos, line, numLines, edgeWidth, edgeHeight, cornerWidth, cornerHeight: LongInt; finalSurface, tmpsurf, rotatedEdge: PSDL_Surface; rect: TSDL_Rect; - chars: set of char = [#9,' ',';',':','?','!',',']; + //chars: set of char = [#9,' ',';',':','?','!',',']; substr: shortstring; edge, corner, tail: TSPrite; begin - case SpeechType of + case SpeechType of 1: begin; edge:= sprSpeechEdge; corner:= sprSpeechCorner; @@ -326,7 +346,7 @@ begin w:= 0; i:= round(Sqrt(length(s)) * 2); - s:= WrapText(s, #1, chars, i); + // s:= WrapText(s, #1, chars, i); pos:= 1; prevpos:= 0; line:= 0; // Find the longest line for the purposes of centring the text. Font dependant. while pos <= length(s) do @@ -463,6 +483,7 @@ SDL_FreeSurface(rotatedEdge); SDL_FreeSurface(finalSurface); + end; end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uScript.pas --- a/hedgewars/uScript.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uScript.pas Thu Nov 22 00:41:53 2012 +0100 @@ -141,7 +141,7 @@ lua_pushnil(L); end else - lua_pushinteger(L, not lua_tointeger(L, 1)); + lua_pushinteger(L, (not lua_tointeger(L, 1))); lc_bnot := 1; end; @@ -1250,7 +1250,9 @@ function lc_endgame(L : Plua_State) : LongInt; Cdecl; begin + {$IFNDEF PAS2C} L:= L; // avoid compiler hint + {$ENDIF} GameState:= gsExit; lc_endgame:= 0 end; @@ -2041,7 +2043,7 @@ procedure ScriptCall(fname : shortstring); begin -if not ScriptLoaded or (not ScriptExists(fname)) then +if (not ScriptLoaded) or (not ScriptExists(fname)) then exit; SetGlobals; lua_getglobal(luaState, Str2PChar(fname)); @@ -2092,7 +2094,7 @@ function ScriptCall(fname : shortstring; par1, par2, par3, par4 : LongInt) : LongInt; begin -if not ScriptLoaded or (not ScriptExists(fname)) then +if (not ScriptLoaded) or (not ScriptExists(fname)) then exit; SetGlobals; lua_getglobal(luaState, Str2PChar(fname)); diff -r 2286a39140da -r 453917e94e55 hedgewars/uSound.pas diff -r 2286a39140da -r 453917e94e55 hedgewars/uStats.pas diff -r 2286a39140da -r 453917e94e55 hedgewars/uStore.pas --- a/hedgewars/uStore.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uStore.pas Thu Nov 22 00:41:53 2012 +0100 @@ -21,7 +21,10 @@ unit uStore; interface -uses {$IFNDEF PAS2C} StrUtils, {$ENDIF}SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat; +uses SysUtils, uConsts, SDLh, GLunit, uTypes, uLandTexture, uCaptions, uChat + {$IFDEF GL2}, uMatrix{$ENDIF} + {$IFNDEF PAS2C}, StrUtils{$ENDIF} + ; procedure initModule; procedure freeModule; @@ -55,6 +58,17 @@ procedure WarpMouse(x, y: Word); inline; procedure SwapBuffers; {$IFDEF USE_VIDEO_RECORDING}cdecl{$ELSE}inline{$ENDIF}; +{$IFDEF GL2} +procedure UpdateModelviewProjection; +procedure EnableTexture(enable:Boolean); +{$ENDIF} + +procedure SetTexCoordPointer(p: Pointer;n: Integer); +procedure SetVertexPointer(p: Pointer;n: Integer); +procedure SetColorPointer(p: Pointer;n: Integer); +procedure BeginWater; +procedure EndWater; + implementation uses uMisc, uConsole, uMobile, uVariables, uUtils, uTextures, uRender, uRenderUtils, uCommands , uPhysFSLayer @@ -72,6 +86,17 @@ SDLPrimSurface: PSDL_Surface; {$ENDIF} +{$IFDEF GL2} + shaderMain: GLuint; + shaderWater: GLuint; + + // attributes +{$ENDIF} + +{$IFDEF WEBGL} + OpenGLSetupedBefore : boolean; +{$ENDIF} + function WriteInRect(Surface: PSDL_Surface; X, Y: LongInt; Color: LongWord; Font: THWFont; s: ansistring): TSDL_Rect; var w, h: LongInt; tmpsurf: PSDL_Surface; @@ -306,7 +331,7 @@ i, imflags: LongInt; begin AddFileLog('StoreLoad()'); - +WriteLnToConsole('Entering StoreLoad'); if not reload then for fi:= Low(THWFont) to High(THWFont) do with Fontz[fi] do @@ -435,6 +460,8 @@ if not reload then AddProgress; IMG_Quit(); + +WriteLnToConsole('Leaving StoreLoad'); end; {$IF NOT DEFINED(S3D_DISABLED) OR DEFINED(USE_VIDEO_RECORDING)} @@ -657,6 +684,8 @@ function glLoadExtension(extension : shortstring) : boolean; begin +//TODO: pas2c doesn't handle {$IF (GLunit = gles11) OR DEFINED(PAS2C)} +{$IFNDEF PAS2C} {$IF GLunit = gles11} // FreePascal doesnt come with OpenGL ES 1.1 Extension headers extension:= extension; // avoid hint @@ -669,6 +698,7 @@ else AddFileLog('OpenGL - "' + extension + '" failed to load'); {$ENDIF} +{$ENDIF} end; procedure SetupOpenGLAttributes; @@ -691,12 +721,117 @@ SDL_GL_SetAttribute(SDL_GL_ACCELERATED_VISUAL, 1); // try to prefer hardware rendering end; +{$IFDEF GL2} +function CompileShader(shaderFile: string; shaderType: GLenum): GLuint; +var + shader: GLuint; + f: Textfile; + source, line: AnsiString; + sourceA: Pchar; + lengthA: GLint; + compileResult: GLint; + logLength: GLint; + log: PChar; +begin + Assign(f, Pathz[ptShaders] + '/' + shaderFile); + filemode:= 0; // readonly + Reset(f); + if IOResult <> 0 then + begin + AddFileLog('Unable to load ' + shaderFile); + halt(-1); + end; + + source:=''; + while not eof(f) do + begin + ReadLn(f, line); + source:= source + line + #10; + end; + + Close(f); + + WriteLnToConsole('Compiling shader: ' + Pathz[ptShaders] + '/' + shaderFile); + + sourceA:=PChar(source); + lengthA:=Length(source); + + shader:=glCreateShader(shaderType); + glShaderSource(shader, 1, @sourceA, @lengthA); + glCompileShader(shader); + glGetShaderiv(shader, GL_COMPILE_STATUS, @compileResult); + glGetShaderiv(shader, GL_INFO_LOG_LENGTH, @logLength); + + if logLength > 1 then + begin + log := GetMem(logLength); + glGetShaderInfoLog(shader, logLength, nil, log); + WriteLnToConsole('========== Compiler log =========='); + WriteLnToConsole(shortstring(log)); + WriteLnToConsole('==================================='); + FreeMem(log, logLength); + end; + + if compileResult <> GL_TRUE then + begin + WriteLnToConsole('Shader compilation failed, halting'); + halt(-1); + end; + + CompileShader:= shader; +end; + +function CompileProgram(shaderName: string): GLuint; +var + program_: GLuint; + vs, fs: GLuint; + linkResult: GLint; + logLength: GLint; + log: PChar; +begin + program_:= glCreateProgram(); + vs:= CompileShader(shaderName + '.vs', GL_VERTEX_SHADER); + fs:= CompileShader(shaderName + '.fs', GL_FRAGMENT_SHADER); + glAttachShader(program_, vs); + glAttachShader(program_, fs); + + glBindAttribLocation(program_, aVertex, PChar('vertex')); + glBindAttribLocation(program_, aTexCoord, PChar('texcoord')); + glBindAttribLocation(program_, aColor, PChar('color')); + + glLinkProgram(program_); + glDeleteShader(vs); + glDeleteShader(fs); + + glGetProgramiv(program_, GL_LINK_STATUS, @linkResult); + glGetProgramiv(program_, GL_INFO_LOG_LENGTH, @logLength); + + if logLength > 1 then + begin + log := GetMem(logLength); + glGetProgramInfoLog(program_, logLength, nil, log); + WriteLnToConsole('========== Compiler log =========='); + WriteLnToConsole(shortstring(log)); + WriteLnToConsole('==================================='); + FreeMem(log, logLength); + end; + + if linkResult <> GL_TRUE then + begin + WriteLnToConsole('Linking program failed, halting'); + halt(-1); + end; + + CompileProgram:= program_; +end; + +{$ENDIF} + procedure SetupOpenGL; //var vendor: shortstring = ''; var buf: array[byte] of char; -{$IFDEF USE_VIDEO_RECORDING} - AuxBufNum: LongInt; -{$ENDIF} +{$IFDEF PAS2C}err: GLenum;{$ENDIF} +{$IFDEF USE_VIDEO_RECORDING}AuxBufNum: LongInt;{$ENDIF} tmpstr: AnsiString; tmpint: LongInt; tmpn: LongInt; @@ -704,6 +839,19 @@ buf[0]:= char(0); // avoid compiler hint AddFileLog('Setting up OpenGL (using driver: ' + shortstring(SDL_VideoDriverName(buf, sizeof(buf))) + ')'); +{$IFDEF WEBGL} + if OpenGLSetupedBefore then + begin + glViewport(0, 0, cScreenWidth, cScreenHeight); + hglMatrixMode(MATRIX_MODELVIEW); + hglLoadIdentity(); + hglScalef(2.0 / cScreenWidth, -2.0 / cScreenHeight, 1.0); + hglTranslatef(0, -cScreenHeight / 2, 0); + exit; + end + OpenGLSetupedBefore := true; +{$ENDIF} + {$IFDEF SDL13} // this function creates an opengles1.1 context by default on mobile devices // unless you un-comment this two attributes @@ -728,7 +876,8 @@ AddFileLog('Texture size too small for backgrounds, disabling.'); end; -(* // find out which gpu we are using (for extension compatibility maybe?) +(* + // find out which gpu we are using (for extension compatibility maybe?) {$IFDEF IPHONEOS} vendor:= vendor; // avoid hint cGPUVendor:= gvApple; @@ -755,8 +904,12 @@ glGetIntegerv(GL_AUX_BUFFERS, @AuxBufNum); AddFileLog(' |----- Number of auxiliary buffers: ' + inttostr(AuxBufNum)); {$ENDIF} +{$IFDEF PAS2C} + + // doesn't seem to print >256 chars + AddFileLogRaw(PChar(glGetString(GL_EXTENSIONS))); +{$ELSE} AddFileLog(' \----- Extensions: '); -{$IFNDEF PAS2C} // fetch extentions and store them in string tmpstr := StrPas(PChar(glGetString(GL_EXTENSIONS))); tmpn := WordCount(tmpstr, [' ']); @@ -774,9 +927,6 @@ tmpint := tmpint + 3; end; until (tmpint > tmpn); -{$ELSE} - // doesn't seem to print >256 chars - AddFileLogRaw(PChar(glGetString(GL_EXTENSIONS))); {$ENDIF} AddFileLog(''); @@ -805,6 +955,39 @@ end; {$ENDIF} +{$IFDEF GL2} + +{$IFDEF PAS2C} + err := glewInit(); + if err <> GLEW_OK then + begin + WriteLnToConsole('Failed to initialize GLEW.'); + halt; + end; +{$ENDIF} + +{$IFNDEF PAS2C} + if not Load_GL_VERSION_2_0 then + halt; +{$ENDIF} + + shaderWater:= CompileProgram('water'); + glUseProgram(shaderWater); + glUniform1i(glGetUniformLocation(shaderWater, pchar('tex0')), 0); + uWaterMVPLocation:= glGetUniformLocation(shaderWater, pchar('mvp')); + + shaderMain:= CompileProgram('default'); + glUseProgram(shaderMain); + glUniform1i(glGetUniformLocation(shaderMain, pchar('tex0')), 0); + uMainMVPLocation:= glGetUniformLocation(shaderMain, pchar('mvp')); + uMainTintLocation:= glGetUniformLocation(shaderMain, pchar('tint')); + + uCurrentMVPLocation:= uMainMVPLocation; + + Tint(255, 255, 255, 255); + UpdateModelviewProjection; +{$ENDIF} + {$IFNDEF S3D_DISABLED} if (cStereoMode = smHorizontal) or (cStereoMode = smVertical) or (cStereoMode = smAFR) then begin @@ -822,18 +1005,31 @@ end; {$ENDIF} - // set view port to whole window - glViewport(0, 0, cScreenWidth, cScreenHeight); +// set view port to whole window +glViewport(0, 0, cScreenWidth, cScreenHeight); +{$IFDEF GL2} + uMatrix.initModule; + hglMatrixMode(MATRIX_MODELVIEW); + // prepare default translation/scaling + hglLoadIdentity(); + hglScalef(2.0 / cScreenWidth, -2.0 / cScreenHeight, 1.0); + hglTranslatef(0, -cScreenHeight / 2, 0); + + EnableTexture(True); + + glEnableVertexAttribArray(aVertex); + glEnableVertexAttribArray(aTexCoord); + glGenBuffers(1, @vBuffer); + glGenBuffers(1, @tBuffer); + glGenBuffers(1, @cBuffer); +{$ELSE} glMatrixMode(GL_MODELVIEW); // prepare default translation/scaling glLoadIdentity(); glScalef(2.0 / cScreenWidth, -2.0 / cScreenHeight, 1.0); glTranslatef(0, -cScreenHeight / 2, 0); - // enable alpha blending - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); // disable/lower perspective correction (will not need it anyway) glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST); // disable dithering @@ -842,8 +1038,92 @@ glEnable(GL_TEXTURE_2D); glEnableClientState(GL_VERTEX_ARRAY); glEnableClientState(GL_TEXTURE_COORD_ARRAY); +{$ENDIF} + + // enable alpha blending + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + // disable/lower perspective correction (will not need it anyway) end; +{$IFDEF GL2} +procedure EnableTexture(enable:Boolean); +begin + if enable then + glUniform1i(glGetUniformLocation(shaderMain, pchar('enableTexture')), 1) + else + glUniform1i(glGetUniformLocation(shaderMain, pchar('enableTexture')), 0); +end; +{$ENDIF} + +procedure SetTexCoordPointer(p: Pointer; n: Integer); +begin + {$IFDEF GL2} + glBindBuffer(GL_ARRAY_BUFFER, tBuffer); + glBufferData(GL_ARRAY_BUFFER, sizeof(GLfloat) * n * 2, p, GL_STATIC_DRAW); + glEnableVertexAttribArray(aTexCoord); + glVertexAttribPointer(aTexCoord, 2, GL_FLOAT, GL_FALSE, 0, pointer(0)); + {$ELSE} + glTexCoordPointer(2, GL_FLOAT, 0, p); + {$ENDIF} +end; + +procedure SetVertexPointer(p: Pointer; n: Integer); +begin + {$IFDEF GL2} + glBindBuffer(GL_ARRAY_BUFFER, vBuffer); + glBufferData(GL_ARRAY_BUFFER, sizeof(GLfloat) * n * 2, p, GL_STATIC_DRAW); + glEnableVertexAttribArray(aVertex); + glVertexAttribPointer(aVertex, 2, GL_FLOAT, GL_FALSE, 0, pointer(0)); + {$ELSE} + glVertexPointer(2, GL_FLOAT, 0, p); + {$ENDIF} +end; + +procedure SetColorPointer(p: Pointer; n: Integer); +begin + {$IFDEF GL2} + glBindBuffer(GL_ARRAY_BUFFER, cBuffer); + glBufferData(GL_ARRAY_BUFFER, n * 4, p, GL_STATIC_DRAW); + glEnableVertexAttribArray(aColor); + glVertexAttribPointer(aColor, 4, GL_UNSIGNED_BYTE, GL_TRUE, 0, pointer(0)); + {$ELSE} + glColorPointer(4, GL_UNSIGNED_BYTE, 0, p); + {$ENDIF} +end; + +{$IFDEF GL2} +procedure UpdateModelviewProjection; +var + mvp: TMatrix4x4f; +begin + //MatrixMultiply(mvp, mProjection, mModelview); + hglMVP(mvp); + glUniformMatrix4fv(uCurrentMVPLocation, 1, GL_FALSE, @mvp[0, 0]); +end; +{$ENDIF} + +(* +procedure UpdateProjection; +var + s: GLfloat; +begin + s:=cScaleFactor; + mProjection[0,0]:= s/cScreenWidth; mProjection[0,1]:= 0.0; mProjection[0,2]:=0.0; mProjection[0,3]:= 0.0; + mProjection[1,0]:= 0.0; mProjection[1,1]:= -s/cScreenHeight; mProjection[1,2]:=0.0; mProjection[1,3]:= 0.0; + mProjection[2,0]:= 0.0; mProjection[2,1]:= 0.0; mProjection[2,2]:=1.0; mProjection[2,3]:= 0.0; + mProjection[3,0]:= cStereoDepth; mProjection[3,1]:= s/2; mProjection[3,2]:=0.0; mProjection[3,3]:= 1.0; + + {$IFDEF GL2} + UpdateModelviewProjection; + {$ELSE} + glMatrixMode(GL_PROJECTION); + glLoadMatrixf(@mProjection[0, 0]); + glMatrixMode(GL_MODELVIEW); + {$ENDIF} +end; +*) + procedure SetScale(f: GLfloat); begin // leave immediately if scale factor did not change @@ -851,18 +1131,62 @@ exit; if f = cDefaultZoomLevel then - glPopMatrix // "return" to default scaling +{$IFDEF GL2} + hglPopMatrix // "return" to default scaling +{$ELSE} + glPopMatrix +{$ENDIF} else // other scaling begin +{$IFDEF GL2} + hglPushMatrix; // save default scaling + hglLoadIdentity; + hglScalef(f / cScreenWidth, -f / cScreenHeight, 1.0); + hglTranslatef(0, -cScreenHeight / 2, 0); +{$ELSE} glPushMatrix; // save default scaling glLoadIdentity; glScalef(f / cScreenWidth, -f / cScreenHeight, 1.0); glTranslatef(0, -cScreenHeight / 2, 0); +{$ENDIF} end; cScaleFactor:= f; + +{$IFDEF GL2} + UpdateModelviewProjection; +{$ENDIF} end; +procedure BeginWater; +begin + {$IFDEF GL2} + glUseProgram(shaderWater); + uCurrentMVPLocation:=uWaterMVPLocation; + UpdateModelviewProjection; + glDisableVertexAttribArray(aTexCoord); + glEnableVertexAttribArray(aColor); + {$ELSE} + glDisableClientState(GL_TEXTURE_COORD_ARRAY); + glEnableClientState(GL_COLOR_ARRAY); + {$ENDIF} +end; + +procedure EndWater; +begin + {$IFDEF GL2} + glUseProgram(shaderMain); + uCurrentMVPLocation:=uMainMVPLocation; + UpdateModelviewProjection; + glDisableVertexAttribArray(aColor); + glEnableVertexAttribArray(aTexCoord); + {$ELSE} + glDisableClientState(GL_COLOR_ARRAY); + glEnableClientState(GL_TEXTURE_COORD_ARRAY); + {$ENDIF} +end; + + //////////////////////////////////////////////////////////////////////////////// procedure AddProgress; var r: TSDL_Rect; @@ -898,6 +1222,7 @@ DrawTextureFromRect( -squaresize div 2, (cScreenHeight - squaresize) shr 1, @r, ProgrTex); SwapBuffers; + inc(Step); end; @@ -1178,9 +1503,11 @@ {$ENDIF} AddFileLog('Freeing old primary surface...'); {$IFNDEF SDL13} + {$IFNDEF WEBGL} SDL_FreeSurface(SDLPrimSurface); SDLPrimSurface:= nil; {$ENDIF} + {$ENDIF} {$ENDIF} end; @@ -1230,6 +1557,7 @@ {$ENDIF} SetupOpenGL(); + if reinit then begin // clean the window from any previous content @@ -1261,6 +1589,10 @@ ProgrTex:= nil; SupportNPOTT:= false; +{$IFDEF WEBGL} + OpenGLSetupedBefore := false; +{$ENDIF} + // init all ammo name texture pointers for ai:= Low(TAmmoType) to High(TAmmoType) do begin @@ -1279,6 +1611,13 @@ procedure freeModule; begin +{$IFDEF GL2} + glDeleteProgram(shaderMain); + glDeleteProgram(shaderWater); + glDeleteBuffers(1, @vBuffer); + glDeleteBuffers(1, @tBuffer); + glDeleteBuffers(1, @cBuffer); +{$ENDIF} StoreRelease(false); TTF_Quit(); {$IFDEF SDL13} diff -r 2286a39140da -r 453917e94e55 hedgewars/uTeams.pas --- a/hedgewars/uTeams.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uTeams.pas Thu Nov 22 00:41:53 2012 +0100 @@ -576,8 +576,9 @@ end; procedure chBind(var id: shortstring); -var KeyName, Modifier, tmp: shortstring; - b: LongInt; +var KeyName, Modifier, tmp : shortstring; + b : LongInt; + i : Integer; begin KeyName:= ''; Modifier:= ''; @@ -585,7 +586,9 @@ if CurrentTeam = nil then exit; -if(Pos('mod:', id) <> 0)then +i := Pos('mod:', id); + +if(i <> 0)then begin tmp:= ''; SplitBySpace(id, tmp); diff -r 2286a39140da -r 453917e94e55 hedgewars/uTypes.pas --- a/hedgewars/uTypes.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uTypes.pas Thu Nov 22 00:41:53 2012 +0100 @@ -44,7 +44,8 @@ // Different files are stored in different folders, this enumeration is used to tell which folder to use TPathType = (ptNone, ptData, ptGraphics, ptThemes, ptCurrTheme, ptTeams, ptMaps, ptMapCurrent, ptDemos, ptSounds, ptGraves, ptFonts, ptForts, - ptLocale, ptAmmoMenu, ptHedgehog, ptVoices, ptHats, ptFlags, ptMissionMaps, ptSuddenDeath, ptButtons); + ptLocale, ptAmmoMenu, ptHedgehog, ptVoices, ptHats, ptFlags, ptMissionMaps, ptSuddenDeath, ptButtons, + ptShaders); // Available sprites for displaying stuff TSprite = (sprWater, sprCloud, sprBomb, sprBigDigit, sprFrame, @@ -200,6 +201,8 @@ X, Y: GLint; end; + TMatrix4x4f = array[0..3, 0..3] of GLfloat; + PTexture = ^TTexture; TTexture = record id: GLuint; @@ -390,12 +393,12 @@ TClan = record Color: Longword; Teams: array[0..Pred(cMaxTeams)] of PTeam; - TeamsNumber: Longword; + TeamsNumber: LongInt;{xymeng, org:LongWord} TagTeamIndex: Longword; CurrTeam: LongWord; ClanHealth: LongInt; ClanIndex: LongInt; - TurnNumber: LongWord; + TurnNumber: LongInt;{xymeng, org:LongWord} Flawless: boolean; end; @@ -430,11 +433,13 @@ gidRandomMineTimer, gidDamageModifier, gidResetHealth, gidAISurvival, gidInfAttack, gidResetWeps, gidPerHogAmmo, gidTagTeam); + TLandArray = packed array of array of LongWord; TCollisionArray = packed array of array of Word; + TDirtyTag = packed array of array of byte; + TPreview = packed array[0..127, 0..31] of byte; - TDirtyTag = packed array of array of byte; - + PWidgetMovement = ^TWidgetMovement; TWidgetMovement = record animate : Boolean; diff -r 2286a39140da -r 453917e94e55 hedgewars/uUtils.pas --- a/hedgewars/uUtils.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uUtils.pas Thu Nov 22 00:41:53 2012 +0100 @@ -25,16 +25,19 @@ procedure SplitBySpace(var a, b: shortstring); procedure SplitByChar(var a, b: shortstring; c: char); -procedure SplitByChar(var a, b: ansistring; c: char); {$IFNDEF PAS2C} +procedure SplitByChar(var a, b: ansistring; c: char); +{$ENDIF} + +//{$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} +//{$ENDIF} function Min(a, b: LongInt): LongInt; inline; function Max(a, b: LongInt): LongInt; inline; @@ -86,7 +89,7 @@ logMutex: TRTLCriticalSection; // mutex for debug file {$ENDIF} {$ENDIF} -var CharArray: array[byte] of Char; +var CharArray: array[0..255] of Char; procedure SplitBySpace(var a,b: shortstring); begin @@ -105,11 +108,15 @@ Inc(a[t], 32); b:= copy(a, i + 1, Length(a) - i); a[0]:= char(Pred(i)) + {$IFDEF PAS2C} + a[i] := 0; + {$ENDIF} end else b:= ''; end; +{$IFNDEF PAS2C} procedure SplitByChar(var a, b: ansistring; c: char); var i: LongInt; begin @@ -119,9 +126,10 @@ b:= copy(a, i + 1, Length(a) - i); setlength(a, Pred(i)); end else b:= ''; -end; +end; { SplitByChar } +{$ENDIF} -{$IFNDEF PAS2C} +//{$IFNDEF PAS2C} function EnumToStr(const en : TGearType) : shortstring; overload; begin EnumToStr:= GetEnumName(TypeInfo(TGearType), ord(en)) @@ -150,7 +158,7 @@ begin EnumToStr := GetEnumName(TypeInfo(TCapGroup), ord(en)) end; -{$ENDIF} +//{$ENDIF} function Min(a, b: LongInt): LongInt; begin @@ -271,10 +279,14 @@ function Str2PChar(const s: shortstring): PChar; +var i :Integer ; begin -CharArray:= s; + for i:= 1 to Length(s) do + begin + CharArray[i - 1] := s[i]; + end; CharArray[Length(s)]:= #0; -Str2PChar:= @CharArray + Str2PChar:= @(CharArray[0]); end; @@ -293,16 +305,21 @@ procedure AddFileLog(s: shortstring); begin -s:= s; +// s:= s; +{$IFNDEF WEBGL} {$IFDEF DEBUGFILE} + {$IFDEF USE_VIDEO_RECORDING} EnterCriticalSection(logMutex); {$ENDIF} writeln(f, inttostr(GameTicks) + ': ' + s); flush(f); + {$IFDEF USE_VIDEO_RECORDING} LeaveCriticalSection(logMutex); {$ENDIF} + +{$ENDIF} {$ENDIF} end; diff -r 2286a39140da -r 453917e94e55 hedgewars/uVariables.pas --- a/hedgewars/uVariables.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uVariables.pas Thu Nov 22 00:41:53 2012 +0100 @@ -21,7 +21,7 @@ unit uVariables; interface -uses SDLh, uTypes, uFloat, GLunit, uConsts, Math, uMobile, uUtils; +uses SDLh, uTypes, uFloat, GLunit, uConsts, Math, uMobile, uUtils, uMatrix; var /////// init flags /////// @@ -76,7 +76,7 @@ CheckSum : LongWord; CampaignVariable: shortstring; - GameTicks : LongWord; + GameTicks : LongInt; {xymeng:originally LongWord} GameState : TGameState; GameType : TGameType; InputMask : LongWord; @@ -194,7 +194,7 @@ LuaGoals : shortstring; - LuaTemplateNumber : LongWord; + LuaTemplateNumber : LongInt; {org: LongWord} VoiceList : array[0..7] of TVoice = ( ( snd: sndNone; voicepack: nil), @@ -242,9 +242,11 @@ '/Graphics/Flags', // ptFlags '/Missions/Maps', // ptMissionMaps '/Graphics/SuddenDeath', // ptSuddenDeath - '/Graphics/Buttons' // ptButton + '/Graphics/Buttons', // ptButton + '/Shaders' // ptShaders ); +var Fontz: array[THWFont] of THHFont = ( (Handle: nil; Height: 12; @@ -820,7 +822,7 @@ TimeAfterTurn: Longword; minAngle, maxAngle: Longword; isDamaging: boolean; - SkipTurns: Longword; + SkipTurns: LongInt; {xymeng, orinally: LongWord} PosCount: Longword; PosSprite: TSprite; ejectX, ejectY: Longint; @@ -2486,6 +2488,7 @@ SyncTexture, ConfirmTexture: PTexture; cScaleFactor: GLfloat; + cStereoDepth: GLfloat; SupportNPOTT: Boolean; Step: LongInt; squaresize : LongInt; @@ -2524,6 +2527,23 @@ lastTurnChecksum : Longword; + mModelview: TMatrix4x4f; + mProjection: TMatrix4x4f; + vBuffer: GLuint; // vertex buffer + tBuffer: GLuint; // texture coords buffer + cBuffer: GLuint; // color buffer + + uCurrentMVPLocation: GLint; + + uMainMVPLocation: GLint; + uMainTintLocation: GLint; + + uWaterMVPLocation: GLint; + + aVertex: GLint; + aTexCoord: GLint; + aColor: GLint; + var trammo: array[TAmmoStrId] of ansistring; // name of the weapon trammoc: array[TAmmoStrId] of ansistring; // caption of the weapon trammod: array[TAmmoStrId] of ansistring; // description of the weapon @@ -2737,6 +2757,13 @@ cMapName:= ''; LuaTemplateNumber:= 0; + cStereoDepth := 0; + +// MatrixLoadIdentity(mModelview); +// MatrixLoadIdentity(mProjection); + aVertex:= 0; + aTexCoord:= 1; + aColor:= 2; end; procedure freeModule; diff -r 2286a39140da -r 453917e94e55 hedgewars/uVisualGears.pas --- a/hedgewars/uVisualGears.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uVisualGears.pas Thu Nov 22 00:41:53 2012 +0100 @@ -82,7 +82,7 @@ // ================================================================== // ================================================================== -const doStepHandlers: array[TVisualGearType] of TVGearStepProcedure = +const vdoStepHandlers: array[TVisualGearType] of TVGearStepProcedure = ( @doStepFlake, @doStepCloud, @@ -160,7 +160,7 @@ gear^.X:= real(X); gear^.Y:= real(Y); gear^.Kind := Kind; -gear^.doStep:= doStepHandlers[Kind]; +gear^.doStep:= vdoStepHandlers[Kind]; gear^.State:= 0; gear^.Tint:= $FFFFFFFF; gear^.uid:= VGCounter; diff -r 2286a39140da -r 453917e94e55 hedgewars/uWeb.pas --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/uWeb.pas Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,174 @@ + +// defines functions used for web port + +unit uWeb; +interface + +type + TResourceList = record + count : Integer; + files : array[0..500] of shortstring; + end; + +function generateResourceList:TResourceList; + +implementation + +uses uConsts, uVariables, uTypes; + +function readThemeCfg:TResourceList; forward; + +function generateResourceList:TResourceList; +var + cfgRes : TResourceList; + i,j : Integer; + t, t2 : shortstring; + si : TSprite; + res : TResourceList; + +begin + + res.count := 0; + + for i:= 0 to Pred(TeamsCount) do + with TeamsArray[i]^ do + begin + Str(i, t); + + res.files[res.count] := UserPathz[ptGraves] + '/' + GraveName; + res.files[res.count + 1] := UserPathz[ptForts] + '/' + FortName; + res.files[res.count + 2] := UserPathz[ptGraphics] + '/' + FortName; + res.files[res.count + 3] := UserPathz[ptFlags] + '/' + flag; + + inc(res.count, 4); + + end; + + for si:= Low(TSprite) to High(TSprite) do + with SpritesData[si] do + begin + Str(si, t); + res.files[res.count] := UserPathz[Path] + '/' + FileName; + res.files[res.count + 1] := UserPathz[AltPath] + '/' + FileName; + inc(res.count, 2); + + end; + + for i:= 0 to Pred(ClansCount) do + with CLansArray[i]^ do + begin + for j:= 0 to Pred(TeamsNumber) do + begin + with Teams[j]^ do + begin + Str(i, t); + Str(j, t2); + res.files[res.count] := UserPathz[ptForts] + '/' + FortName; + inc(res.count); + + end; + end; + end; + + cfgRes := readThemeCfg(); + + for i:= 0 to Pred(cfgRes.count) do + begin + res.files[res.count] := cfgRes.files[i]; + inc(res.count); + end; + + res.files[res.count] := UserPathz[ptFlags] + '/cpu'; + inc(res.count); + + res.files[res.count] := UserPathz[ptFlags] + '/hedgewars'; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraphics] + '/' + cHHFileName; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraphics] + '/Girder'; + inc(res.count); + + res.files[res.count] := UserPathz[ptCurrTheme] + '/LandTex'; + inc(res.count); + + res.files[res.count] := UserPathz[ptCurrTheme] + '/LandBackTex'; + inc(res.count); + + res.files[res.count] := UserPathz[ptCurrTheme] + '/Girder'; + inc(res.count); + + res.files[res.count] := UserPathz[ptCurrTheme] + '/Border'; + inc(res.count); + + res.files[res.count] := UserPathz[ptMapCurrent] + '/mask'; + inc(res.count); + + res.files[res.count] := UserPathz[ptMapCurrent] + '/map'; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraphics] + '/missions'; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraphics] + '/Progress'; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraves] + '/Statue'; + inc(res.count); + + res.files[res.count] := UserPathz[ptGraphics] + '/' + cCHFileName; + inc(res.count); + + generateResourceList:=res; +end; + +function readThemeCfg : TResourceList; +var +s,key : shortstring; +f : TextFile; +i: Integer; +res : TResourceList; +begin + s:=Pathz[ptCurrTheme] + '/' + cThemeCFGFilename; + + Assign(f, s); + {$I-} + + filemode := 0; + Reset(f); + + res.count := 0; + + while not eof(f) do + begin + Readln(f, s); + + if Length(s) = 0 then + continue; + if s[1] = ';' then + continue; + + i:= Pos('=', s); + key:= Trim(Copy(s, 1, Pred(i))); + Delete(s, 1, i); + + if (key = 'object') or (key = 'spray') then + begin + i:=Pos(',', s); + + res.files[res.count] := Pathz[ptCurrTheme] + '/' + Trim(Copy(s, 1, Pred(i))); + res.files[res.count + 1] := Pathz[ptGraphics] + '/' + Trim(Copy(s, 1, Pred(i))); + inc(res.count, 2); + + end; + + end; + + close(f); + {$I+} + + readThemeCfg := res; +end; + +end. diff -r 2286a39140da -r 453917e94e55 hedgewars/uWorld.pas --- a/hedgewars/uWorld.pas Wed Nov 21 23:34:54 2012 +0100 +++ b/hedgewars/uWorld.pas Thu Nov 22 00:41:53 2012 +0100 @@ -64,6 +64,9 @@ {$IFDEF USE_VIDEO_RECORDING} , uVideoRec {$ENDIF} +{$IFDEF GL2} + , uMatrix +{$ENDIF} ; var cWaveWidth, cWaveHeight: LongInt; @@ -755,9 +758,9 @@ end; procedure DrawWater(Alpha: byte; OffsetY: LongInt); -var VertexBuffer: array [0..3] of TVertex2f; - r: TSDL_Rect; - lw, lh: GLfloat; +var VertexBuffer : array [0..3] of TVertex2f; + r : TSDL_Rect; + lw, lh : GLfloat; begin if SuddenDeathDmg then begin @@ -783,7 +786,7 @@ begin if r.y < 0 then r.y:= 0; - + glDisable(GL_TEXTURE_2D); VertexBuffer[0].X:= -lw; VertexBuffer[0].Y:= r.y; @@ -794,6 +797,7 @@ VertexBuffer[3].X:= -lw; VertexBuffer[3].Y:= lh; +{$IFNDEF GL2} glDisableClientState(GL_TEXTURE_COORD_ARRAY); glEnableClientState(GL_COLOR_ARRAY); if SuddenDeathDmg then @@ -807,8 +811,29 @@ glDisableClientState(GL_COLOR_ARRAY); glEnableClientState(GL_TEXTURE_COORD_ARRAY); + +{$ELSE} + UpdateModelviewProjection; + + BeginWater; + if SuddenDeathDmg then + SetColorPointer(@SDWaterColorArray[0], 4) + else + SetColorPointer(@WaterColorArray[0], 4); + + SetVertexPointer(@VertexBuffer[0], 4); + + glDrawArrays(GL_TRIANGLE_FAN, 0, 4); + + EndWater; +{$ENDIF} + + {$IFNDEF GL2} glColor4ub($FF, $FF, $FF, $FF); // must not be Tint() as color array seems to stay active and color reset is required + {$ENDIF} + {$IFNDEF WEBGL} glEnable(GL_TEXTURE_2D); + {$ENDIF} end; end; @@ -862,8 +887,13 @@ TextureBuffer[3].Y:= TextureBuffer[2].Y; -glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); -glTexCoordPointer(2, GL_FLOAT, 0, @TextureBuffer[0]); +SetVertexPointer(@VertexBuffer[0], Length(VertexBuffer)); +SetTexCoordPointer(@TextureBuffer[0], Length(VertexBuffer)); + +{$IFDEF GL2} +UpdateModelviewProjection; +{$ENDIF} + glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); Tint($FF, $FF, $FF, $FF); @@ -1084,24 +1114,34 @@ else if rm = rmLeftEye then d:= -d; stereoDepth:= stereoDepth + d; + + {$IFDEF GL2} + hglMatrixMode(MATRIX_PROJECTION); + hglTranslatef(d, 0, 0); + hglMatrixMode(MATRIX_MODELVIEW); + {$ELSE} glMatrixMode(GL_PROJECTION); glTranslatef(d, 0, 0); glMatrixMode(GL_MODELVIEW); + {$ENDIF} {$ENDIF} end; procedure ResetDepth(rm: TRenderMode); begin -{$IFDEF S3D_DISABLED} - rm:= rm; // avoid hint - exit; -{$ELSE} +{$IFNDEF S3D_DISABLED} if rm = rmDefault then exit; + {$IFDEF GL2} + hglMatrixMode(MATRIX_PROJECTION); + hglTranslatef(-stereoDepth, 0, 0); + hglMatrixMode(MATRIX_MODELVIEW); + {$ELSE} glMatrixMode(GL_PROJECTION); glTranslatef(-stereoDepth, 0, 0); glMatrixMode(GL_MODELVIEW); - stereoDepth:= 0; + {$ENDIF} + cStereoDepth:= 0; {$ENDIF} end; @@ -1161,6 +1201,30 @@ DrawWater(255, 0); +(* +// Attack bar + if CurrentTeam <> nil then + case AttackBar of + //1: begin + //r:= StuffPoz[sPowerBar]; + //{$WARNINGS OFF} + //r.w:= (CurrentHedgehog^.Gear^.Power * 256) div cPowerDivisor; + //{$WARNINGS ON} + //DrawSpriteFromRect(r, cScreenWidth - 272, cScreenHeight - 48, 16, 0, Surface); + //end; + 2: with CurrentHedgehog^ do + begin + tdx:= hwSign(Gear^.dX) * Sin(Gear^.Angle * Pi / cMaxAngle); + tdy:= - Cos(Gear^.Angle * Pi / cMaxAngle); + for i:= (Gear^.Power * 24) div cPowerDivisor downto 0 do + DrawSprite(sprPower, + hwRound(Gear^.X) + GetLaunchX(CurAmmoType, hwSign(Gear^.dX), Gear^.Angle) + LongInt(round(WorldDx + tdx * (24 + i * 2))) - 16, + hwRound(Gear^.Y) + GetLaunchY(CurAmmoType, Gear^.Angle) + LongInt(round(WorldDy + tdy * (24 + i * 2))) - 16, + i) + end + end; +*) + DrawVisualGears(1); DrawGears; DrawVisualGears(6); @@ -1427,12 +1491,13 @@ // Chat DrawChat; + // various captions if fastUntilLag then DrawTextureCentered(0, (cScreenHeight shr 1), SyncTexture); if isPaused then DrawTextureCentered(0, (cScreenHeight shr 1), PauseTexture); -if not isFirstFrame and (missionTimer <> 0) or isPaused or fastUntilLag or (GameState = gsConfirm) then +if (not isFirstFrame) and (missionTimer <> 0) or isPaused or fastUntilLag or (GameState = gsConfirm) then begin if (ReadyTimeLeft = 0) and (missionTimer > 0) then dec(missionTimer, Lag); @@ -1549,11 +1614,11 @@ glDisable(GL_TEXTURE_2D); glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); - glDrawArrays(GL_TRIANGLE_FAN, 0, Length(VertexBuffer)); + glDrawArrays(GL_TRIANGLE_FAN, 0, High(VertexBuffer) - Low(VertexBuffer) + 1); glEnable(GL_TEXTURE_2D); Tint($FF, $FF, $FF, $FF); - if not isFirstFrame and ((ScreenFadeValue = 0) or (ScreenFadeValue = sfMax)) then + if (not isFirstFrame) and ((ScreenFadeValue = 0) or (ScreenFadeValue = sfMax)) then ScreenFade:= sfNone end end; @@ -1628,6 +1693,7 @@ DrawSprite(sprArrow, CursorPoint.X, cScreenHeight - CursorPoint.Y, (RealTicks shr 6) mod 8) end end; + isFirstFrame:= false end; diff -r 2286a39140da -r 453917e94e55 hedgewars/videorec/avwrapper.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/hedgewars/videorec/avwrapper.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,509 @@ +/* + * Hedgewars, a free turn based strategy game + * Copyright (c) 2004-2012 Andrey Korotaev + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + */ + +#include +#include +#include +#include +#include +#include "libavformat/avformat.h" +#include "libavutil/mathematics.h" + +#ifndef AVIO_FLAG_WRITE +#define AVIO_FLAG_WRITE AVIO_WRONLY +#endif + +static AVFormatContext* g_pContainer; +static AVOutputFormat* g_pFormat; +static AVStream* g_pAStream; +static AVStream* g_pVStream; +static AVFrame* g_pAFrame; +static AVFrame* g_pVFrame; +static AVCodec* g_pACodec; +static AVCodec* g_pVCodec; +static AVCodecContext* g_pAudio; +static AVCodecContext* g_pVideo; + +static int g_Width, g_Height; +static uint32_t g_Frequency, g_Channels; +static int g_VQuality; +static AVRational g_Framerate; + +static FILE* g_pSoundFile; +static int16_t* g_pSamples; +static int g_NumSamples; + + +#if LIBAVCODEC_VERSION_MAJOR < 54 +#define OUTBUFFER_SIZE 200000 +static uint8_t g_OutBuffer[OUTBUFFER_SIZE]; +#endif + +// pointer to function from hwengine (uUtils.pas) +static void (*AddFileLogRaw)(const char* pString); + +static void FatalError(const char* pFmt, ...) +{ + char Buffer[1024]; + va_list VaArgs; + + va_start(VaArgs, pFmt); + vsnprintf(Buffer, 1024, pFmt, VaArgs); + va_end(VaArgs); + + AddFileLogRaw("Error in av-wrapper: "); + AddFileLogRaw(Buffer); + AddFileLogRaw("\n"); + exit(1); +} + +// Function to be called from libav for logging. +// Note: libav can call LogCallback from different threads +// (there is mutex in AddFileLogRaw). +static void LogCallback(void* p, int Level, const char* pFmt, va_list VaArgs) +{ + char Buffer[1024]; + + vsnprintf(Buffer, 1024, pFmt, VaArgs); + AddFileLogRaw(Buffer); +} + +static void Log(const char* pFmt, ...) +{ + char Buffer[1024]; + va_list VaArgs; + + va_start(VaArgs, pFmt); + vsnprintf(Buffer, 1024, pFmt, VaArgs); + va_end(VaArgs); + + AddFileLogRaw(Buffer); +} + +static void AddAudioStream() +{ +#if LIBAVFORMAT_VERSION_MAJOR >= 53 + g_pAStream = avformat_new_stream(g_pContainer, g_pACodec); +#else + g_pAStream = av_new_stream(g_pContainer, 1); +#endif + if(!g_pAStream) + { + Log("Could not allocate audio stream\n"); + return; + } + g_pAStream->id = 1; + + g_pAudio = g_pAStream->codec; + + avcodec_get_context_defaults3(g_pAudio, g_pACodec); + g_pAudio->codec_id = g_pACodec->id; + + // put parameters + g_pAudio->sample_fmt = AV_SAMPLE_FMT_S16; + g_pAudio->sample_rate = g_Frequency; + g_pAudio->channels = g_Channels; + + // set quality + g_pAudio->bit_rate = 160000; + + // for codecs that support variable bitrate use it, it should be better + g_pAudio->flags |= CODEC_FLAG_QSCALE; + g_pAudio->global_quality = 1*FF_QP2LAMBDA; + + // some formats want stream headers to be separate + if (g_pFormat->flags & AVFMT_GLOBALHEADER) + g_pAudio->flags |= CODEC_FLAG_GLOBAL_HEADER; + + // open it +#if LIBAVCODEC_VERSION_MAJOR >= 53 + if (avcodec_open2(g_pAudio, g_pACodec, NULL) < 0) +#else + if (avcodec_open(g_pAudio, g_pACodec) < 0) +#endif + { + Log("Could not open audio codec %s\n", g_pACodec->long_name); + return; + } + +#if LIBAVCODEC_VERSION_MAJOR >= 54 + if (g_pACodec->capabilities & CODEC_CAP_VARIABLE_FRAME_SIZE) +#else + if (g_pAudio->frame_size == 0) +#endif + g_NumSamples = 4096; + else + g_NumSamples = g_pAudio->frame_size; + g_pSamples = (int16_t*)av_malloc(g_NumSamples*g_Channels*sizeof(int16_t)); + g_pAFrame = avcodec_alloc_frame(); + if (!g_pAFrame) + { + Log("Could not allocate frame\n"); + return; + } +} + +// returns non-zero if there is more sound +static int WriteAudioFrame() +{ + if (!g_pAStream) + return 0; + + AVPacket Packet = { 0 }; + av_init_packet(&Packet); + + int NumSamples = fread(g_pSamples, 2*g_Channels, g_NumSamples, g_pSoundFile); + +#if LIBAVCODEC_VERSION_MAJOR >= 53 + AVFrame* pFrame = NULL; + if (NumSamples > 0) + { + g_pAFrame->nb_samples = NumSamples; + avcodec_fill_audio_frame(g_pAFrame, g_Channels, AV_SAMPLE_FMT_S16, + (uint8_t*)g_pSamples, NumSamples*2*g_Channels, 1); + pFrame = g_pAFrame; + } + // when NumSamples == 0 we still need to call encode_audio2 to flush + int got_packet; + if (avcodec_encode_audio2(g_pAudio, &Packet, pFrame, &got_packet) != 0) + FatalError("avcodec_encode_audio2 failed"); + if (!got_packet) + return 0; +#else + if (NumSamples == 0) + return 0; + int BufferSize = OUTBUFFER_SIZE; + if (g_pAudio->frame_size == 0) + BufferSize = NumSamples*g_Channels*2; + Packet.size = avcodec_encode_audio(g_pAudio, g_OutBuffer, BufferSize, g_pSamples); + if (Packet.size == 0) + return 1; + if (g_pAudio->coded_frame && g_pAudio->coded_frame->pts != AV_NOPTS_VALUE) + Packet.pts = av_rescale_q(g_pAudio->coded_frame->pts, g_pAudio->time_base, g_pAStream->time_base); + Packet.flags |= AV_PKT_FLAG_KEY; + Packet.data = g_OutBuffer; +#endif + + // Write the compressed frame to the media file. + Packet.stream_index = g_pAStream->index; + if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) + FatalError("Error while writing audio frame"); + return 1; +} + +// add a video output stream +static void AddVideoStream() +{ +#if LIBAVFORMAT_VERSION_MAJOR >= 53 + g_pVStream = avformat_new_stream(g_pContainer, g_pVCodec); +#else + g_pVStream = av_new_stream(g_pContainer, 0); +#endif + if (!g_pVStream) + FatalError("Could not allocate video stream"); + + g_pVideo = g_pVStream->codec; + + avcodec_get_context_defaults3(g_pVideo, g_pVCodec); + g_pVideo->codec_id = g_pVCodec->id; + + // put parameters + // resolution must be a multiple of two + g_pVideo->width = g_Width & ~1; // make even (dimensions should be even) + g_pVideo->height = g_Height & ~1; // make even + /* time base: this is the fundamental unit of time (in seconds) in terms + of which frame timestamps are represented. for fixed-fps content, + timebase should be 1/framerate and timestamp increments should be + identically 1. */ + g_pVideo->time_base.den = g_Framerate.num; + g_pVideo->time_base.num = g_Framerate.den; + //g_pVideo->gop_size = 12; /* emit one intra frame every twelve frames at most */ + g_pVideo->pix_fmt = PIX_FMT_YUV420P; + + // set quality + if (g_VQuality > 100) + g_pVideo->bit_rate = g_VQuality; + else + { + g_pVideo->flags |= CODEC_FLAG_QSCALE; + g_pVideo->global_quality = g_VQuality*FF_QP2LAMBDA; + } + + // some formats want stream headers to be separate + if (g_pFormat->flags & AVFMT_GLOBALHEADER) + g_pVideo->flags |= CODEC_FLAG_GLOBAL_HEADER; + +#if LIBAVCODEC_VERSION_MAJOR < 53 + // for some versions of ffmpeg x264 options must be set explicitly + if (strcmp(g_pVCodec->name, "libx264") == 0) + { + g_pVideo->coder_type = FF_CODER_TYPE_AC; + g_pVideo->flags |= CODEC_FLAG_LOOP_FILTER; + g_pVideo->crf = 23; + g_pVideo->thread_count = 3; + g_pVideo->me_cmp = FF_CMP_CHROMA; + g_pVideo->partitions = X264_PART_I8X8 | X264_PART_I4X4 | X264_PART_P8X8 | X264_PART_B8X8; + g_pVideo->me_method = ME_HEX; + g_pVideo->me_subpel_quality = 7; + g_pVideo->me_range = 16; + g_pVideo->gop_size = 250; + g_pVideo->keyint_min = 25; + g_pVideo->scenechange_threshold = 40; + g_pVideo->i_quant_factor = 0.71; + g_pVideo->b_frame_strategy = 1; + g_pVideo->qcompress = 0.6; + g_pVideo->qmin = 10; + g_pVideo->qmax = 51; + g_pVideo->max_qdiff = 4; + g_pVideo->max_b_frames = 3; + g_pVideo->refs = 3; + g_pVideo->directpred = 1; + g_pVideo->trellis = 1; + g_pVideo->flags2 = CODEC_FLAG2_BPYRAMID | CODEC_FLAG2_MIXED_REFS | CODEC_FLAG2_WPRED | CODEC_FLAG2_8X8DCT | CODEC_FLAG2_FASTPSKIP; + g_pVideo->weighted_p_pred = 2; + } +#endif + + // open the codec +#if LIBAVCODEC_VERSION_MAJOR >= 53 + AVDictionary* pDict = NULL; + if (strcmp(g_pVCodec->name, "libx264") == 0) + av_dict_set(&pDict, "preset", "medium", 0); + + if (avcodec_open2(g_pVideo, g_pVCodec, &pDict) < 0) +#else + if (avcodec_open(g_pVideo, g_pVCodec) < 0) +#endif + FatalError("Could not open video codec %s", g_pVCodec->long_name); + + g_pVFrame = avcodec_alloc_frame(); + if (!g_pVFrame) + FatalError("Could not allocate frame"); + + g_pVFrame->linesize[0] = g_Width; + g_pVFrame->linesize[1] = g_Width/2; + g_pVFrame->linesize[2] = g_Width/2; + g_pVFrame->linesize[3] = 0; +} + +static int WriteFrame(AVFrame* pFrame) +{ + double AudioTime, VideoTime; + + // write interleaved audio frame + if (g_pAStream) + { + VideoTime = (double)g_pVStream->pts.val*g_pVStream->time_base.num/g_pVStream->time_base.den; + do + AudioTime = (double)g_pAStream->pts.val*g_pAStream->time_base.num/g_pAStream->time_base.den; + while (AudioTime < VideoTime && WriteAudioFrame()); + } + + if (!g_pVStream) + return 0; + + AVPacket Packet; + av_init_packet(&Packet); + Packet.data = NULL; + Packet.size = 0; + + g_pVFrame->pts++; + if (g_pFormat->flags & AVFMT_RAWPICTURE) + { + /* raw video case. The API will change slightly in the near + future for that. */ + Packet.flags |= AV_PKT_FLAG_KEY; + Packet.stream_index = g_pVStream->index; + Packet.data = (uint8_t*)pFrame; + Packet.size = sizeof(AVPicture); + + if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) + FatalError("Error while writing video frame"); + return 0; + } + else + { +#if LIBAVCODEC_VERSION_MAJOR >= 54 + int got_packet; + if (avcodec_encode_video2(g_pVideo, &Packet, pFrame, &got_packet) < 0) + FatalError("avcodec_encode_video2 failed"); + if (!got_packet) + return 0; + + if (Packet.pts != AV_NOPTS_VALUE) + Packet.pts = av_rescale_q(Packet.pts, g_pVideo->time_base, g_pVStream->time_base); + if (Packet.dts != AV_NOPTS_VALUE) + Packet.dts = av_rescale_q(Packet.dts, g_pVideo->time_base, g_pVStream->time_base); +#else + Packet.size = avcodec_encode_video(g_pVideo, g_OutBuffer, OUTBUFFER_SIZE, pFrame); + if (Packet.size < 0) + FatalError("avcodec_encode_video failed"); + if (Packet.size == 0) + return 0; + + if( g_pVideo->coded_frame->pts != AV_NOPTS_VALUE) + Packet.pts = av_rescale_q(g_pVideo->coded_frame->pts, g_pVideo->time_base, g_pVStream->time_base); + if( g_pVideo->coded_frame->key_frame ) + Packet.flags |= AV_PKT_FLAG_KEY; + Packet.data = g_OutBuffer; +#endif + // write the compressed frame in the media file + Packet.stream_index = g_pVStream->index; + if (av_interleaved_write_frame(g_pContainer, &Packet) != 0) + FatalError("Error while writing video frame"); + + return 1; + } +} + +void AVWrapper_WriteFrame(uint8_t* pY, uint8_t* pCb, uint8_t* pCr) +{ + g_pVFrame->data[0] = pY; + g_pVFrame->data[1] = pCb; + g_pVFrame->data[2] = pCr; + WriteFrame(g_pVFrame); +} + +void AVWrapper_Init( + void (*pAddFileLogRaw)(const char*), + const char* pFilename, + const char* pDesc, + const char* pSoundFile, + const char* pFormatName, + const char* pVCodecName, + const char* pACodecName, + int Width, int Height, + int FramerateNum, int FramerateDen, + int VQuality) +{ + AddFileLogRaw = pAddFileLogRaw; + av_log_set_callback( &LogCallback ); + + g_Width = Width; + g_Height = Height; + g_Framerate.num = FramerateNum; + g_Framerate.den = FramerateDen; + g_VQuality = VQuality; + + // initialize libav and register all codecs and formats + av_register_all(); + + // find format + g_pFormat = av_guess_format(pFormatName, NULL, NULL); + if (!g_pFormat) + FatalError("Format \"%s\" was not found", pFormatName); + + // allocate the output media context + g_pContainer = avformat_alloc_context(); + if (!g_pContainer) + FatalError("Could not allocate output context"); + + g_pContainer->oformat = g_pFormat; + + // store description of file + av_dict_set(&g_pContainer->metadata, "comment", pDesc, 0); + + // append extesnion to filename + char ext[16]; + strncpy(ext, g_pFormat->extensions, 16); + ext[15] = 0; + ext[strcspn(ext,",")] = 0; + snprintf(g_pContainer->filename, sizeof(g_pContainer->filename), "%s.%s", pFilename, ext); + + // find codecs + g_pVCodec = avcodec_find_encoder_by_name(pVCodecName); + g_pACodec = avcodec_find_encoder_by_name(pACodecName); + + // add audio and video stream to container + g_pVStream = NULL; + g_pAStream = NULL; + + if (g_pVCodec) + AddVideoStream(); + else + Log("Video codec \"%s\" was not found; video will be ignored.\n", pVCodecName); + + if (g_pACodec) + { + g_pSoundFile = fopen(pSoundFile, "rb"); + if (g_pSoundFile) + { + fread(&g_Frequency, 4, 1, g_pSoundFile); + fread(&g_Channels, 4, 1, g_pSoundFile); + AddAudioStream(); + } + else + Log("Could not open %s\n", pSoundFile); + } + else + Log("Audio codec \"%s\" was not found; audio will be ignored.\n", pACodecName); + + if (!g_pAStream && !g_pVStream) + FatalError("No video, no audio, aborting..."); + + // write format info to log + av_dump_format(g_pContainer, 0, g_pContainer->filename, 1); + + // open the output file, if needed + if (!(g_pFormat->flags & AVFMT_NOFILE)) + { + if (avio_open(&g_pContainer->pb, g_pContainer->filename, AVIO_FLAG_WRITE) < 0) + FatalError("Could not open output file (%s)", g_pContainer->filename); + } + + // write the stream header, if any + avformat_write_header(g_pContainer, NULL); + + g_pVFrame->pts = -1; +} + +void AVWrapper_Close() +{ + // output buffered frames + if (g_pVCodec->capabilities & CODEC_CAP_DELAY) + while( WriteFrame(NULL) ); + // output any remaining audio + while( WriteAudioFrame() ); + + // write the trailer, if any. + av_write_trailer(g_pContainer); + + // close the output file + if (!(g_pFormat->flags & AVFMT_NOFILE)) + avio_close(g_pContainer->pb); + + // free everything + if (g_pVStream) + { + avcodec_close(g_pVideo); + av_free(g_pVideo); + av_free(g_pVStream); + av_free(g_pVFrame); + } + if (g_pAStream) + { + avcodec_close(g_pAudio); + av_free(g_pAudio); + av_free(g_pAStream); + av_free(g_pAFrame); + av_free(g_pSamples); + fclose(g_pSoundFile); + } + + av_free(g_pContainer); +} diff -r 2286a39140da -r 453917e94e55 misc/liblua/CMakeLists.txt --- a/misc/liblua/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/misc/liblua/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -1,5 +1,7 @@ #this file is included only when system Lua library is not found +#TODO: when NOPASCAL=1 it should use clang here too + file(GLOB lua_src *.c *.h) if(WIN32) diff -r 2286a39140da -r 453917e94e55 misc/libopenalbridge/CMakeLists.txt --- a/misc/libopenalbridge/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/misc/libopenalbridge/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -37,6 +37,6 @@ endif(WIN32) #type make openalbridge_test to get a small executable test -add_executable(openalbridge_test "${hedgewars_SOURCE_DIR}/misc/libopenalbridge/tester.c") +add_executable(openalbridge_test "${CMAKE_SOURCE_DIR}/misc/libopenalbridge/tester.c") target_link_libraries(openalbridge_test openalbridge ${OPENAL_LIBRARY} ${OGGVORBIS_LIBRARIES}) diff -r 2286a39140da -r 453917e94e55 misc/physfs/CMakeLists.txt --- a/misc/physfs/CMakeLists.txt Wed Nov 21 23:34:54 2012 +0100 +++ b/misc/physfs/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -34,6 +34,7 @@ INCLUDE(CheckLibraryExists) INCLUDE(CheckCSourceCompiles) +find_package(SDL REQUIRED) include_directories(${CMAKE_CURRENT_SOURCE_DIR}/src) include_directories(${SDL_INCLUDE_DIR}) #hw include_directories(${LUA_INCLUDE_DIR}) #hw @@ -278,7 +279,6 @@ ENDIF(PHYSFS_BUILD_STATIC) IF(PHYSFS_BUILD_SHARED) - find_package(SDL REQUIRED) ADD_LIBRARY(physfs SHARED ${PHYSFS_SRCS}) SET_TARGET_PROPERTIES(physfs PROPERTIES VERSION ${PHYSFS_VERSION}) SET_TARGET_PROPERTIES(physfs PROPERTIES SOVERSION ${PHYSFS_SOVERSION}) diff -r 2286a39140da -r 453917e94e55 project_files/hwc/CMakeLists.txt --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,103 @@ + +#only Clang is supported +if(CLANG) + set(clang_executable ${CLANG}) +else() + find_program(clang_executable + NAMES clang-mp-3.2 clang-mp-3.1 clang-mp-3.0 clang + PATHS /opt/local/bin /usr/local/bin /usr/bin) +endif() + +if (clang_executable) + exec_program(${clang_executable} ARGS "-v" OUTPUT_VARIABLE clang_version_full) + string(REGEX MATCH "[0-9]+\\.[0-9]+" clang_version_long "${clang_version_full}") + string(REGEX REPLACE "([0-9]+\\.[0-9]+)" "\\1" clang_version "${clang_version_long}") + #TODO: check version >= 3.0 + message(STATUS "Found CLANG: ${clang_executable} (version ${clang_version})") +else() + message(FATAL_ERROR "No LLVM/Clang compiler found (required for engine_c target)") +endif() + +set(CMAKE_C_COMPILER ${clang_executable}) + + +#the usual set of dependencies +find_package(OpenGL REQUIRED) +find_package(GLEW REQUIRED) +find_package(SDL REQUIRED) +find_package(SDL_mixer REQUIRED) +find_package(SDL_net REQUIRED) +find_package(SDL_image REQUIRED) +find_package(SDL_ttf REQUIRED) + +#compile our rtl implementation +add_subdirectory(rtl) +include_directories("${GLEW_INCLUDE_PATH}") +include_directories("${CMAKE_CURRENT_SOURCE_DIR}/rtl") + +configure_file(${CMAKE_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc) + +#get the list of pas files that are going to be converted and compiled +file(GLOB engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/*.pas") +#TODO: temporary until cmake can configure itself accordingly +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uWeb.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uVideoRec.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/uTouch.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/PNGh.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/pas2cSystem.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/pas2cRedo.pas") +list(REMOVE_ITEM engine_sources_pas "${CMAKE_SOURCE_DIR}/hedgewars/hwLibrary.pas") + +foreach(sourcefile ${engine_sources_pas}) + get_filename_component(sourcename ${sourcefile} NAME_WE) #drops .pas + set(engine_sources "${CMAKE_CURRENT_BINARY_DIR}/${sourcename}.c" ${engine_sources}) +endforeach() + +#invoke pas2c on our pas files +add_custom_command(OUTPUT ${engine_sources} + COMMAND "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}" + ARGS -n "hwengine" + -i "${CMAKE_SOURCE_DIR}/hedgewars" + -o "${CMAKE_CURRENT_BINARY_DIR}" + -a "${CMAKE_CURRENT_BINARY_DIR}" + DEPENDS pas2c + ) +add_custom_target(engine_c DEPENDS ${engine_sources}) + + +#compile the c files +add_executable(hwengine WIN32 ${engine_sources}) + +target_link_libraries(hwengine fpcrtl + ${LUA_LIBRARY} + ${OPENGL_LIBRARY} + ${SDL_LIBRARY} + ${SDLMIXER_LIBRARY} + ${SDLNET_LIBRARY} + ${SDLIMAGE_LIBRARY} + ${SDLTTF_LIBRARY} + #TODO: add other libraries + ) + +#TODO: move this away in its proper findxxx.cmake +if(APPLE) + #let's look for the installed sdlmain file; if it is not found, let's build our own + find_package(SDL REQUIRED) + #remove the ";-framework Cocoa" from the SDL_LIBRARY variable + string(REGEX REPLACE "(.*);-.*" "\\1" sdl_dir "${SDL_LIBRARY}") + #find libsdmain.a + find_file(SDLMAIN_LIB libSDLMain.a PATHS ${sdl_dir}/Resources/) + + if(SDLMAIN_LIB MATCHES "SDLMAIN_LIB-NOTFOUND") + include_directories(${SDL_INCLUDE_DIR}) + add_library (SDLmain STATIC ${CMAKE_SOURCE_DIR}/hedgewars/sdlmain_osx/SDLMain.m) + #add a dependency to the hwengine target + set(SDLMAIN_LIB "${LIBRARY_OUTPUT_PATH}/libSDLmain.a") + endif() + + target_link_libraries(hwengine ${SDLMAIN_LIB}) +endif(APPLE) + + +install(PROGRAMS "${EXECUTABLE_OUTPUT_PATH}/hwengine${CMAKE_EXECUTABLE_SUFFIX}" DESTINATION ${target_dir}) + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/SysUtils.h diff -r 2286a39140da -r 453917e94e55 project_files/hwc/Types.h diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/CMakeLists.txt --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,16 @@ + +include_directories(${GLEW_INCLUDE_PATH}) + +file(GLOB fpcrtl_src *.c) + +add_library(fpcrtl ${fpcrtl_src}) + +#if(WEBGL) +# set_target_properties(fpcrtl PROPERTIES PREFIX "em") +# set_target_properties(fpcrtl PROPERTIES SUFFIX ".bc") +#endif(WEBGL) + + + + + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/GL.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/GL.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,8 @@ +#pragma once + +#ifdef __APPLE__ +#include +#else +#include "GL/gl.h" +#endif + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/Math.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/Math.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,4 @@ +#pragma once + +#include + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/SysUtils.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/SysUtils.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,41 @@ +#ifndef _FPCRTL_SYSUTILS_H_ +#define _FPCRTL_SYSUTILS_H_ + +#include "Types.h" + +// EFFECTS: return the current date time in pascal notation +// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT +TDateTime fpcrtl_now(); +#define now fpcrtl_now +#define Now fpcrtl_now + +// EFFECTS: return the current time +// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT +TDateTime fpcrtl_time(); + + +// EFFECTS: return the current date +// http://www.merlyn.demon.co.uk/del-prgg.htm#TDT +TDateTime fpcrtl_date(); +#define date fpcrtl_date +#define Date fpcrtl_date + +// EFFECTS: Trim strips blank characters (spaces) at the beginning and end of S +// and returns the resulting string. Only #32 characters are stripped. +// If the string contains only spaces, an empty string is returned. +string255 fpcrtl_trim(string255 s); +#define trim fpcrtl_trim +#define Trim fpcrtl_trim + +Integer fpcrtl_strToInt(string255 s); +#define StrToInt fpcrtl_strToInt +#define strToInt fpcrtl_strToInt + +string255 fpcrtl_extractFileName(string255 f); +#define fpcrtl_ExtractFileName fpcrtl_extractFileName + +string255 fpcrtl_strPas(PChar); +#define fpcrtl_StrPas fpcrtl_strPas + + +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/Types.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/Types.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,39 @@ +#ifndef _TYPES_H_ +#define _TYPES_H_ + +#include "pas2c.h" + +/* + * Not very useful currently + */ + +typedef double TDate; +typedef double TTime; +typedef double TDateTime; +typedef string255 TMonthNameArray[13]; +typedef string255 TWeekNameArray[8]; + +typedef struct { + Byte CurrencyFormat; + Byte NegCurrFormat; + Char ThousandSeparator; + Char DecimalSeparator; + Byte CurrencyDecimals; + Char DateSeparator; + Char TimeSeparator; + Char ListSeparator; + string255 CurrencyString; + string255 ShortDateFormat; + string255 LongDateFormat; + string255 TimeAMString; + string255 TimePMString; + string255 ShortTimeFormat; + string255 LongTimeFormat; + TMonthNameArray ShortMonthNames; + TMonthNameArray LongMonthNames; + TWeekNameArray ShortDayNames; + TWeekNameArray LongDayNames; + Word TwoDigitYearCenturyWindow; +}TFormatSettings; + +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/fileio.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/fileio.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,226 @@ +/* + * XXX: assume all files are text files + */ + +#include "misc.h" +#include "fileio.h" +#include +#include +#include +#include + +io_result_t IOResult; +int FileMode; + +static void init(File f) { + f->fp = NULL; + f->eof = 0; + f->mode = NULL; + f->record_len = 0; +} + +void fpcrtl_assign__vars(File *f, string255 name) { + FIX_STRING(name); + *f = (File) malloc(sizeof(file_wrapper_t)); + strcpy((*f)->file_name, name.str); + init(*f); +} + +void fpcrtl_reset1(File f) { + f->fp = fopen(f->file_name, "r"); + if (!f->fp) { + IOResult = IO_ERROR_DUMMY; + printf("Failed to open %s\n", f->file_name); + return; + } else { +#ifdef FPCRTL_DEBUG + printf("Opened %s\n", f->file_name); +#endif + } + IOResult = IO_NO_ERROR; + f->mode = "r"; +} + +void fpcrtl_reset2(File f, int l) { + f->eof = 0; + f->fp = fopen(f->file_name, "rb"); + if (!f->fp) { + IOResult = IO_ERROR_DUMMY; + printf("Failed to open %s\n", f->file_name); + return; + } + IOResult = IO_NO_ERROR; + f->mode = "rb"; + f->record_len = l; +} + +void __attribute__((overloadable)) fpcrtl_rewrite(File f) { + f->fp = fopen(f->file_name, "w+"); + if (!f->fp) { + IOResult = IO_ERROR_DUMMY; + return; + } + IOResult = IO_NO_ERROR; + f->mode = "w+"; +} + +void __attribute__((overloadable)) fpcrtl_rewrite(File f, Integer l) { + IOResult = IO_NO_ERROR; + fpcrtl_rewrite(f); + if (f->fp) { + f->record_len = l; + } +} + +void fpcrtl_close(File f) { + IOResult = IO_NO_ERROR; + fclose(f->fp); + free(f); +} + +boolean fpcrtl_eof(File f) { + IOResult = IO_NO_ERROR; + if (f->eof || f->fp == NULL || feof(f->fp)) { + return true; + } else { + return false; + } +} + +void __attribute__((overloadable)) fpcrtl_readLn(File f) { + IOResult = IO_NO_ERROR; + char line[256]; + if (fgets(line, sizeof(line), f->fp) == NULL) { + f->eof = 1; + } + if (feof(f->fp)) { + f->eof = 1; + } +} + +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, Integer *i) { + string255 s; + + if (feof(f->fp)) { + f->eof = 1; + return; + } + + fpcrtl_readLn__vars(f, &s); + + *i = atoi(s.str); +} + +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, LongWord *i) { + string255 s; + + if (feof(f->fp)) { + f->eof = 1; + return; + } + + fpcrtl_readLn__vars(f, &s); + + *i = atoi(s.str); +} + +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, string255 *s) { + + if (fgets(s->str, 255, f->fp) == NULL) { + + s->len = 0; + s->str[0] = 0; + + f->eof = 1; + return; + } + + if (feof(f->fp)) { + s->len = 0; + f->eof = 1; + return; + } + + IOResult = IO_NO_ERROR; + + s->len = strlen(s->str); + if ((s->len > 0) && (s->str[s->len - 1] == '\n')) { + s->str[s->len - 1] = 0; + s->len--; + } +} + +void __attribute__((overloadable)) fpcrtl_write(File f, string255 s) { + FIX_STRING(s); + fprintf(f->fp, "%s", s.str); +} + +void __attribute__((overloadable)) fpcrtl_write(FILE *f, string255 s) { + FIX_STRING(s); + fprintf(f, "%s", s.str); +} + +void __attribute__((overloadable)) fpcrtl_writeLn(File f, string255 s) { + FIX_STRING(s); + fprintf(f->fp, "%s\n", s.str); +} + +void __attribute__((overloadable)) fpcrtl_writeLn(FILE *f, string255 s) { + FIX_STRING(s); + fprintf(f, "%s\n", s.str); +} + +void fpcrtl_blockRead__vars(File f, void *buf, Integer count, Integer *result) { + assert(f->record_len > 0); + *result = fread(buf, f->record_len, count, f->fp); +} + +/* + * XXX: dummy blockWrite + */ +void fpcrtl_blockWrite__vars(File f, const void *buf, Integer count, + Integer *result) { + assert(0); +} + +bool fpcrtl_directoryExists(string255 dir) { + + struct stat st; + FIX_STRING(dir); + + IOResult = IO_NO_ERROR; + +#ifdef FPCRTL_DEBUG + printf("Warning: directoryExists is called. This may not work when compiled to js.\n"); +#endif + + if (stat(dir.str, &st) == 0) { + return true; + } + + return false; +} + +bool fpcrtl_fileExists(string255 filename) { + + FIX_STRING(filename); + + IOResult = IO_NO_ERROR; + + FILE *fp = fopen(filename.str, "r"); + if (fp) { + fclose(fp); + return true; + } + return false; +} + +void __attribute__((overloadable)) fpcrtl_flush(Text f) { + printf("flush not implemented\n"); + assert(0); +} + +void __attribute__((overloadable)) fpcrtl_flush(FILE *f) { + fflush(f); +} + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/fileio.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/fileio.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,78 @@ +#ifndef FILEIO_H_ +#define FILEIO_H_ + +#include +#include "Types.h" +#include "misc.h" + +extern int FileMode; + +typedef enum{ + IO_NO_ERROR = 0, + IO_ERROR_DUMMY = 1 +}io_result_t; + +extern io_result_t IOResult; + +typedef struct{ + FILE *fp; + const char* mode; + char file_name[256]; + int eof; + int record_len; +}file_wrapper_t; + +typedef file_wrapper_t* File; +typedef File Text; +typedef Text TextFile; + +void __attribute__((overloadable)) fpcrtl_readLn(File f); +#define fpcrtl_readLn1(f) fpcrtl_readLn(f) + +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, Integer *i); +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, LongWord *i); +void __attribute__((overloadable)) fpcrtl_readLn__vars(File f, string255 *s); +#define fpcrtl_readLn2(f, t) fpcrtl_readLn__vars(f, &(t)) + +#define fpcrtl_readLn(...) macro_dispatcher(fpcrtl_readLn, __VA_ARGS__)(__VA_ARGS__) + + +void fpcrtl_blockRead__vars(File f, void *buf, Integer count, Integer *result); +#define fpcrtl_blockRead(f, buf, count, result) fpcrtl_blockRead__vars(f, &(buf), count, &(result)) +#define fpcrtl_BlockRead fpcrtl_blockRead + +#define fpcrtl_assign(f, name) fpcrtl_assign__vars(&f, name) +void fpcrtl_assign__vars(File *f, string255 name); + +boolean fpcrtl_eof(File f); + +void fpcrtl_reset1(File f); +void fpcrtl_reset2(File f, Integer l); +#define fpcrtl_reset1(f) fpcrtl_reset1(f) +#define fpcrtl_reset2(f, l) fpcrtl_reset2(f, l) +#define fpcrtl_reset(...) macro_dispatcher(fpcrtl_reset, __VA_ARGS__)(__VA_ARGS__) + +void fpcrtl_close(File f); + +void __attribute__((overloadable)) fpcrtl_rewrite(File f); +void __attribute__((overloadable)) fpcrtl_rewrite(File f, Integer l); + +void __attribute__((overloadable)) fpcrtl_flush(Text f); +void __attribute__((overloadable)) fpcrtl_flush(FILE *f); + +void __attribute__((overloadable)) fpcrtl_write(File f, string255 s); +void __attribute__((overloadable)) fpcrtl_write(FILE *f, string255 s); +void __attribute__((overloadable)) fpcrtl_writeLn(File f, string255 s); +void __attribute__((overloadable)) fpcrtl_writeLn(FILE *f, string255 s); + +void fpcrtl_blockWrite__vars(File f, const void *buf, Integer count, Integer *result); +#define fpcrtl_blockWrite(f, buf, count, result) fpcrtl_blockWrite__vars(f, &(buf), count, &(result)) +#define fpcrtl_BlockWrite fpcrtl_blockWrite + +bool fpcrtl_directoryExists(string255 dir); +#define fpcrtl_DirectoryExists fpcrtl_directoryExists + +bool fpcrtl_fileExists(string255 filename); +#define fpcrtl_FileExists fpcrtl_fileExists + +#endif /* FILEIO_H_ */ diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/fpcrtl.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/fpcrtl.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,192 @@ +#ifndef _FPCRTL_H_ +#define _FPCRTL_H_ + +#include +#include +#include +#include +#include + +#include "SysUtils.h" +#include "system.h" +#include "misc.h" +#include "fileio.h" +#include "pmath.h" + +#ifndef EMSCRIPTEN +#if __APPLE__ +#define main SDL_main +#endif +#include "GL/glew.h" +#endif + +#define fpcrtl_memcpy memcpy + +#define luapas_lua_gettop lua_gettop +#define luapas_lua_close lua_close +#define luapas_lua_createtable lua_createtable +#define luapas_lua_error lua_error +#define luapas_lua_gc lua_gc +#define luapas_lua_getfield lua_getfield +#define luapas_lua_objlen lua_objlen +#define luapas_lua_call lua_call +#define luapas_lua_pcall lua_pcall +#define luapas_lua_pushboolean lua_pushboolean +#define luapas_lua_pushcclosure lua_pushcclosure +#define luapas_lua_pushinteger lua_pushinteger +#define luapas_lua_pushnil lua_pushnil +#define luapas_lua_pushnumber lua_pushnumber +#define luapas_lua_pushlstring lua_pushlstring +#define luapas_lua_pushstring lua_pushstring +#define luapas_lua_pushvalue lua_pushvalue +#define luapas_lua_rawgeti lua_rawgeti +#define luapas_lua_setfield lua_setfield +#define luapas_lua_settop lua_settop +#define luapas_lua_toboolean lua_toboolean +#define luapas_lua_tointeger lua_tointeger +#define luapas_lua_tolstring lua_tolstring +#define luapas_lua_tonumber lua_tonumber +#define luapas_lua_type lua_type +#define luapas_lua_typename lua_typename +#define luapas_luaL_argerror luaL_argerror +#define luapas_luaL_checkinteger luaL_checkinteger +#define luapas_luaL_checklstring luaL_checklstring +#define luapas_luaL_loadfile luaL_loadfile +#define luapas_luaL_loadstring luaL_loadstring +#define luapas_luaL_newstate luaL_newstate +#define luapas_luaL_optinteger luaL_optinteger +#define luapas_luaL_optlstring luaL_optlstring +#define luapas_luaL_prepbuffer luaL_prepbuffer +#define luapas_luaL_ref luaL_ref +#define luapas_luaL_unref luaL_unref +#define luapas_luaopen_base luaopen_base +#define luapas_luaopen_math luaopen_math +#define luapas_luaopen_string luaopen_string +#define luapas_luaopen_table luaopen_table + +#define sdlh_IMG_Load IMG_Load + +#ifndef EMSCRIPTEN +#define sdlh_Mix_AllocateChannels Mix_AllocateChannels +#define sdlh_Mix_CloseAudio Mix_CloseAudio +#define sdlh_Mix_FadeInChannelTimed Mix_FadeInChannelTimed +#define sdlh_Mix_FadeInMusic Mix_FadeInMusic +#define sdlh_Mix_FadeOutChannel Mix_FadeOutChannel +#define sdlh_Mix_FreeChunk Mix_FreeChunk +#define sdlh_Mix_FreeMusic Mix_FreeMusic +#define sdlh_Mix_HaltChannel Mix_HaltChannel +#define sdlh_Mix_HaltMusic Mix_HaltMusic +#define sdlh_Mix_LoadMUS Mix_LoadMUS +#define sdlh_Mix_LoadWAV_RW Mix_LoadWAV_RW +#define sdlh_Mix_OpenAudio Mix_OpenAudio +#define sdlh_Mix_PauseMusic Mix_PauseMusic +#define sdlh_Mix_PlayChannelTimed Mix_PlayChannelTimed +#define sdlh_Mix_Playing Mix_Playing +#define sdlh_Mix_ResumeMusic Mix_ResumeMusic +#define sdlh_Mix_Volume Mix_Volume +#define sdlh_Mix_VolumeMusic Mix_VolumeMusic +#else +#define sdlh_Mix_AllocateChannels stub_Mix_AllocateChannels +#define sdlh_Mix_CloseAudio stub_Mix_CloseAudio +#define sdlh_Mix_FadeInChannelTimed stub_Mix_FadeInChannelTimed +#define sdlh_Mix_FadeInMusic stub_Mix_FadeInMusic +#define sdlh_Mix_FadeOutChannel stub_Mix_FadeOutChannel +#define sdlh_Mix_FreeChunk stub_Mix_FreeChunk +#define sdlh_Mix_FreeMusic stub_Mix_FreeMusic +#define sdlh_Mix_HaltChannel stub_Mix_HaltChannel +#define sdlh_Mix_HaltMusic stub_Mix_HaltMusic +#define sdlh_Mix_LoadMUS stub_Mix_LoadMUS +#define sdlh_Mix_LoadWAV_RW stub_Mix_LoadWAV_RW +#define sdlh_Mix_OpenAudio stub_Mix_OpenAudio +#define sdlh_Mix_PauseMusic stub_Mix_PauseMusic +#define sdlh_Mix_PlayChannelTimed stub_Mix_PlayChannelTimed +#define sdlh_Mix_Playing stub_Mix_Playing +#define sdlh_Mix_ResumeMusic stub_Mix_ResumeMusic +#define sdlh_Mix_Volume stub_Mix_Volume +#define sdlh_Mix_VolumeMusic stub_Mix_VolumeMusic +#endif + +#define sdlh_SDL_ConvertSurface SDL_ConvertSurface +#define sdlh_SDL_CreateRGBSurface SDL_CreateRGBSurface +#define sdlh_SDL_CreateThread SDL_CreateThread +#define sdlh_SDL_Delay SDL_Delay +#define sdlh_SDL_EnableKeyRepeat SDL_EnableKeyRepeat +#define sdlh_SDL_EnableUNICODE SDL_EnableUNICODE +#define sdlh_SDL_FillRect SDL_FillRect +#define sdlh_SDL_FreeSurface SDL_FreeSurface +#define sdlh_SDL_GetError SDL_GetError +#define sdlh_SDL_GetKeyName SDL_GetKeyName +#define sdlh_SDL_GetKeyState SDL_GetKeyState +#define sdlh_SDL_GetMouseState SDL_GetMouseState +#define sdlh_SDL_GetRGBA SDL_GetRGBA +#define sdlh_SDL_GetTicks SDL_GetTicks +#define sdlh_SDL_GL_SetAttribute SDL_GL_SetAttribute +#define sdlh_SDL_GL_SwapBuffers SDL_GL_SwapBuffers +#define sdlh_SDL_Init SDL_Init +#define sdlh_SDL_InitSubSystem SDL_InitSubSystem +#define sdlh_SDL_JoystickClose SDL_JoystickClose +#define sdlh_SDL_JoystickEventState SDL_JoystickEventState +#define sdlh_SDL_JoystickName SDL_JoystickName +#define sdlh_SDL_JoystickNumAxes SDL_JoystickNumAxes +#define sdlh_SDL_JoystickNumButtons SDL_JoystickNumButtons +#define sdlh_SDL_JoystickNumHats SDL_JoystickNumHats +#define sdlh_SDL_JoystickOpen SDL_JoystickOpen +#define sdlh_SDL_LockSurface SDL_LockSurface +#define sdlh_SDL_MapRGB SDL_MapRGB +#define sdlh_SDL_MapRGBA SDL_MapRGBA +#define sdlh_SDL_NumJoysticks SDL_NumJoysticks +#define sdlh_SDL_PeepEvents SDL_PeepEvents +#define sdlh_SDL_PumpEvents SDL_PumpEvents +#define sdlh_SDL_Quit SDL_Quit +#define sdlh_SDL_RWFromFile SDL_RWFromFile +#define sdlh_SDL_SetColorKey SDL_SetColorKey +#define sdlh_SDL_SetVideoMode SDL_SetVideoMode +#ifndef EMSCRIPTEN +#define sdlh_SDL_ShowCursor SDL_ShowCursor +#else +#define sdlh_SDL_ShowCursor SDL_ShowCursor_patch +#endif +#define sdlh_SDL_UnlockSurface SDL_UnlockSurface +#define sdlh_SDL_UpperBlit SDL_UpperBlit +#define sdlh_SDL_VideoDriverName SDL_VideoDriverName +#define sdlh_SDL_WarpMouse SDL_WarpMouse +#define sdlh_SDL_WM_SetCaption SDL_WM_SetCaption +#define sdlh_SDL_WM_SetIcon SDL_WM_SetIcon +#define sdlh_SDLNet_AddSocket SDLNet_AddSocket +#define sdlh_SDLNet_AllocSocketSet SDLNet_AllocSocketSet +#define sdlh_SDLNet_CheckSockets SDLNet_CheckSockets +#define sdlh_SDLNet_FreeSocketSet SDLNet_FreeSocketSet +#define sdlh_SDLNet_Init SDLNet_Init +#define sdlh_SDLNet_Quit SDLNet_Quit +#define sdlh_SDLNet_ResolveHost SDLNet_ResolveHost +#define sdlh_SDLNet_TCP_Close SDLNet_TCP_Close +#define sdlh_SDLNet_TCP_Open SDLNet_TCP_Open +#define sdlh_SDLNet_TCP_Recv SDLNet_TCP_Recv +#define sdlh_SDLNet_TCP_Send SDLNet_TCP_Send +#define sdlh_TTF_Init TTF_Init +#define sdlh_TTF_OpenFont TTF_OpenFont +#define sdlh_TTF_Quit TTF_Quit +#define sdlh_TTF_RenderUTF8_Blended TTF_RenderUTF8_Blended +#define sdlh_TTF_RenderUTF8_Solid TTF_RenderUTF8_Solid +#define sdlh_TTF_SetFontStyle TTF_SetFontStyle +#define sdlh_TTF_SizeUTF8 TTF_SizeUTF8 + +#define _strconcat fpcrtl_strconcat +#define _strappend fpcrtl_strappend +#define _strprepend fpcrtl_strprepend +#define _strcompare fpcrtl_strcompare +#define _strncompare fpcrtl_strncompare +#define _strcomparec fpcrtl_strcomparec +#define _chrconcat fpcrtl_chrconcat +#define _pchar fpcrtl_pchar + +// hooks are implemented in javascript +void start_hook(void); +void mainloop_hook(void); +void clear_filelist_hook(void); +void add_file_hook(const char* ptr); +void idb_loader_hook(); +void showcursor_hook(); +void hidecursor_hook(); +void drawworld_init_hook(); +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/misc.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/misc.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,168 @@ +#include "misc.h" +#include +#include +#include +#include + +char strbuf[512]; + +void fpcrtl_assert(int i) +{ + if(!i){ + assert(0); + } +} + +// EFFECTS: return the nearest integer of the given number +int fpcrtl_round(double number) +{ + return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); +} + +void fpcrtl_printf(const char* format, ...) +{ +#ifdef FPCRTL_DEBUG + va_list args; + va_start (args, format); + vprintf (format, args); + va_end (args); +#endif +} + +// +//void fpcrtl_check_string(string255 str) +//{ +//#ifdef FPCRTL_DEBUG +// int len = strlen(str.str); +// if(len != str.len){ +// printf("String %s internal inconsistency error. Length should be %d but actually is %d.\n", str.str, len, str.len); +// } +// //assert(len == str.len); +//#endif +//} + +string255 fpcrtl_strconcat(string255 str1, string255 str2) +{ + //printf("str1 = %d, %d\n", str1.len, strlen(str1.str)); + //printf("str2 = %d, %d\n", str2.len, strlen(str2.str)); + +#ifdef FPCRTL_DEBUG + if(str1.len + (int)(str2.len) > 255){ + printf("String overflow\n"); + printf("str1(%d): %s\nstr2(%d): %s\n", str1.len, str1.str, str2.len, str2.str); + printf("String will be truncated.\n"); + + strbuf[0] = 0; + strcpy(strbuf, str1.str); + strcat(strbuf, str2.str); + memcpy(str1.str, strbuf, 255); + str1.str[254] = 0; + + return str1; + } +#endif + + memcpy(&(str1.str[str1.len]), str2.str, str2.len); + str1.str[str1.len + str2.len] = 0; + str1.len += str2.len; + + return str1; +} + +string255 fpcrtl_strappend(string255 s, char c) +{ + s.str[s.len] = c; + s.str[s.len + 1] = 0; + s.len ++; + + return s; +} + +string255 fpcrtl_strprepend(char c, string255 s) +{ + FIX_STRING(s); + + memmove(s.str + 1, s.str, s.len + 1); // also move '/0' + s.str[0] = c; + s.len++; + + return s; +} + +string255 fpcrtl_chrconcat(char a, char b) +{ + string255 result; + + result.len = 2; + result.str[0] = a; + result.str[1] = b; + result.str[2] = 0; + + return result; +} + +bool fpcrtl_strcompare(string255 str1, string255 str2) +{ + //printf("str1 = %d, %d\n", str1.len, strlen(str1.str)); + //printf("str2 = %d, %d\n", str2.len, strlen(str2.str)); + FIX_STRING(str1); + FIX_STRING(str2); + + if(strcmp(str1.str, str2.str) == 0){ + return true; + } + + return false; +} + +bool fpcrtl_strcomparec(string255 a, char b) +{ + FIX_STRING(a); + + if(a.len == 1 && a.str[0] == b){ + return true; + } + + return false; +} + +bool fpcrtl_strncompare(string255 a, string255 b) +{ + return !fpcrtl_strcompare(a, b); +} + +//char* fpcrtl_pchar(string255 s) +//{ +// return s.str; +//} + +string255 fpcrtl_pchar2str(char *s) +{ + string255 result; + int t = strlen(s); + + if(t > 255){ + printf("pchar2str, length > 255\n"); + assert(0); + } + + result.len = t; + memcpy(result.str, s, t); + result.str[t] = 0; + + return result; +} + +string255 fpcrtl_make_string(const char* s) { + string255 result; + strcpy(result.str, s); + result.len = strlen(s); + return result; +} + +#ifdef EMSCRIPTEN +GLenum glewInit() +{ + return GLEW_OK; +} +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/misc.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/misc.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,58 @@ +#ifndef _FPCRTL_MISC_H_ +#define _FPCRTL_MISC_H_ + +#include "pas2c.h" +#include +#include + +#ifdef EMSCRIPTEN +#include +#else +#include +#endif + +#define VA_NUM_ARGS(...) VA_NUM_ARGS_IMPL(__VA_ARGS__, 5,4,3,2,1) +#define VA_NUM_ARGS_IMPL(_1,_2,_3,_4,_5,N,...) N + +#define macro_dispatcher(func, ...) macro_dispatcher_(func, VA_NUM_ARGS(__VA_ARGS__)) +#define macro_dispatcher_(func, nargs) macro_dispatcher__(func, nargs) +#define macro_dispatcher__(func, nargs) func ## nargs + +#define FPCRTL_DEBUG + +#define FIX_STRING(s) (s.str[s.len] = 0) + +//#define fpcrtl_check_string(s) do{ if(strlen((s).str) != (s).len){ \ +// printf("String %s internal inconsistency error. Length should be %d but actually is %d.\n", (s).str, strlen((s).str), (s).len); \ +// assert(0);\ +// }}while(0) + +void fpcrtl_assert(int); +void fpcrtl_print_trace (void); + +int fpcrtl_round(double number); +void fpcrtl_printf(const char* format, ...); + +string255 fpcrtl_make_string(const char* s); + +string255 fpcrtl_strconcat(string255 str1, string255 str2); +string255 fpcrtl_strappend(string255 s, char c); +string255 fpcrtl_strprepend(char c, string255 s); +string255 fpcrtl_chrconcat(char a, char b); + +// return true if str1 == str2 +bool fpcrtl_strcompare(string255 str1, string255 str2); +bool fpcrtl_strcomparec(string255 a, char b); +bool fpcrtl_strncompare(string255 a, string255 b); + +#define fpcrtl__pchar(s) ((s).str) +string255 fpcrtl_pchar2str(char *s); + +#define fpcrtl_TypeInfo sizeof // dummy + +#ifdef EMSCRIPTEN +#define GLEW_OK 1 +GLenum glewInit(); +#endif + +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/pas2c.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/pas2c.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,80 @@ +#pragma once + +#include +#include +#include +#include +#include + +#define MAX_PARAMS 64 + +typedef union string255_ + { + struct { + char s[257]; + }; + struct { + unsigned char len; + char str[256]; + }; + } string255; +typedef struct string192_ + { + char s[193]; + } string192; +typedef struct string31_ + { + char s[32]; + } string31; +typedef struct string15_ + { + char s[16]; + } string15; + +typedef string255 shortstring; +typedef string255 ansistring; + +typedef uint8_t Byte; +typedef int8_t ShortInt; +typedef uint16_t Word; +typedef int16_t SmallInt; +typedef uint32_t LongWord; +typedef int32_t LongInt; +typedef uint64_t QWord; +typedef int64_t Int64; +typedef LongWord Cardinal; + +typedef LongInt Integer; +typedef float extended; +typedef float real; +typedef float single; + +typedef bool boolean; +typedef int LongBool; + +typedef void * pointer; +typedef Byte * PByte; +typedef char * PChar; +typedef LongInt * PLongInt; +typedef LongWord * PLongWord; +typedef Integer * PInteger; +typedef int PtrInt; +typedef wchar_t widechar; +typedef wchar_t* PWideChar; +typedef char Char; +typedef LongInt SizeInt; +typedef char ** PPChar; +typedef Word* PWord; + +string255 _strconcat(string255 a, string255 b); +string255 _strappend(string255 s, char c); +string255 _strprepend(char c, string255 s); +string255 _chrconcat(char a, char b); +bool _strcompare(string255 a, string255 b); +bool _strcomparec(string255 a, char b); +bool _strncompare(string255 a, string255 b); + + +#define STRINIT(a) {.len = sizeof(a) - 1, .str = a} + + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/pmath.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/pmath.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,49 @@ +#include "pmath.h" +#include +#include + +/* + * power raises base to the power power. + * This is equivalent to exp(power*ln(base)). Therefore base should be non-negative. + */ +float fpcrtl_power(float base, float exponent) +{ + return exp(exponent * log(base)); +} + +/* Currently the games only uses sign of an integer */ +int fpcrtl_signi(int x) +{ + if(x > 0){ + return 1; + } + else if(x < 0){ + return -1; + } + else{ + return 0; + } +} + +float fpcrtl_csc(float x) +{ + return 1 / sin(x); +} + +float __attribute__((overloadable)) fpcrtl_abs(float x) +{ + return fabs(x); +} +double __attribute__((overloadable)) fpcrtl_abs(double x) +{ + return fabs(x); +} +int __attribute__((overloadable)) fpcrtl_abs(int x) +{ + return abs(x); +} + +int64_t __attribute__((overloadable)) fpcrtl_abs(int64_t x) +{ + return x < 0 ? -x : x; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/pmath.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/pmath.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,24 @@ +#ifndef PMATH_H_ +#define PMATH_H_ + +#include +#include + +#define fpcrtl_min(a, b) ((a) < (b) ? (a) : (b)) +#define fpcrtl_max(a, b) ((a) > (b) ? (a) : (b)) + +float fpcrtl_power(float base, float exponent); + +/* Currently the games only uses sign of an integer */ +int fpcrtl_signi(int x); + +float fpcrtl_csc(float x); + +#define fpcrtl_arctan2(y, x) atan2(y, x) + +float __attribute__((overloadable)) fpcrtl_abs(float x); +double __attribute__((overloadable)) fpcrtl_abs(double x); +int __attribute__((overloadable)) fpcrtl_abs(int x); +int64_t __attribute__((overloadable)) fpcrtl_abs(int64_t x); + +#endif /* PMATH_H_ */ diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/system.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/system.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,284 @@ +#include "system.h" +#include +#include +#include +#include + +#ifndef M_PI +// some math.h do not have M_PI macros +# define M_PI 3.14159265358979323846 /* pi */ +# define M_PI_2 1.57079632679489661923 /* pi/2 */ +# define M_PI_4 0.78539816339744830962 /* pi/4 */ +# define M_PIl 3.1415926535897932384626433832795029L /* pi */ +# define M_PI_2l 1.5707963267948966192313216916397514L /* pi/2 */ +# define M_PI_4l 0.7853981633974483096156608458198757L /* pi/4 */ +#endif + +double pi = M_PI; + +int paramCount; +string255 params[MAX_PARAMS]; + +string255 fpcrtl_copy(string255 s, Integer index, Integer count) { + string255 result = STRINIT(""); + + if (count < 1) { + return result; + } + + if (index < 1) { + index = 1; + } + + if (index > s.len) { + return result; + } + + if (index + count > s.len + 1) { + count = s.len + 1 - index; + } + + memcpy(result.str, s.str + index - 1, count); + + result.str[count] = 0; + result.len = count; + + return result; +} + +void fpcrtl_delete__vars(string255 *s, SizeInt index, SizeInt count) { + // number of chars to be move + int num_move; + int new_length; + + string255 temp = *s; + + if (index < 1) { + // in fpc, if index < 1, the string won't be modified + return; + } + + if(index > s->len){ + return; + } + + if (count > s->len - index + 1) { + s->str[index - 1] = 0; + s->len = index - 1; + return; + } + + num_move = s->len - index + 1 - count; + new_length = s->len - count; + + memmove(s->str + index - 1, temp.str + index - 1 + count, num_move); + s->str[new_length] = 0; + + s->len = new_length; + +} + +string255 fpcrtl_floatToStr(double n) { + string255 t; + sprintf(t.str, "%f", n); + t.len = strlen(t.str); + + return t; +} + +void fpcrtl_move__vars(void *src, void *dst, SizeInt count) { + memmove(dst, src, count); +} + +Integer __attribute__((overloadable)) fpcrtl_pos(Char c, string255 str) { + string255 t; + t.len = 1; + t.str[0] = c; + t.str[1] = 0; + return fpcrtl_pos(t, str); +} + +Integer __attribute__((overloadable)) fpcrtl_pos(string255 substr, string255 str) { + + char* p; + + FIX_STRING(substr); + FIX_STRING(str); + + if (str.len == 0) { + return 0; + } + + if (substr.len == 0) { + return 0; + } + + str.str[str.len] = 0; + substr.str[substr.len] = 0; + + p = strstr(str.str, substr.str); + + if (p == NULL) { + return 0; + } + + return strlen(str.str) - strlen(p) + 1; +} + +Integer fpcrtl_length(string255 s) { + return s.len; +} + +string255 fpcrtl_lowerCase(string255 s) { + int i; + + for (i = 0; i < s.len; i++) { + if (s.str[i] >= 'A' && s.str[i] <= 'Z') { + s.str[i] += 'a' - 'A'; + } + } + + return s; +} + +void fpcrtl_fillChar__vars(void *x, SizeInt count, Byte value) { + memset(x, value, count); +} + +void fpcrtl_new__vars(void **p, int size) { + *p = malloc(size); +} + +Integer fpcrtl_trunc(extended n) { + return (int) n; +} + +LongInt str_to_int(char *src) +{ + int i; + int len = strlen(src); + char *end; + for(i = 0; i < len; i++) + { + if(src[i] == '$'){ + // hex + return strtol(src + i + 1, &end, 16); + } + } + + // decimal + return atoi(src); +} +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongInt *a, + LongInt *c) { + *c = 0; // no error + FIX_STRING(s); + *a = str_to_int(s.str); +} + +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, Byte *a, + LongInt *c) { + *c = 0; // no error + FIX_STRING(s); + *a = str_to_int(s.str); +} + +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongWord *a, + LongInt *c) { + *c = 0; // no error + FIX_STRING(s); + *a = str_to_int(s.str); +} + +LongInt fpcrtl_random(LongInt l) { + return (LongInt) (rand() / (double) RAND_MAX * l); +} + +void __attribute__((overloadable)) fpcrtl_str__vars(float x, string255 *s) { + sprintf(s->str, "%f", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(double x, string255 *s) { + sprintf(s->str, "%f", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(uint8_t x, string255 *s) { + sprintf(s->str, "%u", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(int8_t x, string255 *s) { + sprintf(s->str, "%d", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(uint16_t x, string255 *s) { + sprintf(s->str, "%u", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(int16_t x, string255 *s) { + sprintf(s->str, "%d", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(uint32_t x, string255 *s) { + sprintf(s->str, "%u", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(int32_t x, string255 *s) { + sprintf(s->str, "%d", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(uint64_t x, string255 *s) { + sprintf(s->str, "%llu", x); + s->len = strlen(s->str); +} +void __attribute__((overloadable)) fpcrtl_str__vars(int64_t x, string255 *s) { + sprintf(s->str, "%lld", x); + s->len = strlen(s->str); +} + +/* + * XXX No protection currently! + */ +void fpcrtl_interlockedIncrement__vars(int *i) { + (*i)++; +} + +void fpcrtl_interlockedDecrement__vars(int *i) { + (*i)--; +} + +/* + * This function should be called when entering main + */ +void fpcrtl_init(int argc, char** argv) { + int i; + paramCount = argc; + + printf("ARGC = %d\n", paramCount); + + for (i = 0; i < argc; i++) { + if (strlen(argv[i]) > 255) { + assert(0); + } + strcpy(params[i].str, argv[i]); + params[i].len = strlen(params[i].str); + } + +} + +int fpcrtl_paramCount() { + return paramCount - 1; // ignore the first one +} + +string255 fpcrtl_paramStr(int i) { + return params[i]; +} + +int fpcrtl_UTF8ToUnicode(PWideChar dest, PChar src, SizeInt maxLen) { + //return swprintf(dest, maxLen, L"%hs", "src"); //doesn't work in emscripten + return 0; +} + +uint32_t __attribute__((overloadable)) fpcrtl_lo(uint64_t i) { + return (i & 0xFFFFFFFF); +} + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/system.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/system.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,169 @@ +#ifndef SYSTEM_H_ +#define SYSTEM_H_ + +#include +#include "Types.h" +#include "misc.h" + +extern double pi; + +typedef TDate* PDate; + +// dimension info for dynamic arrays +typedef struct { + int dim; + int a[4]; // at most 4 +} fpcrtl_dimension_t; + +/* + * Copy returns a string which is a copy if the Count characters in S, starting at position Index. + * If Count is larger than the length of the string S, the result is truncated. + * If Index is larger than the length of the string S, then an empty string is returned. + * Index is 1-based. + */ +string255 fpcrtl_copy(string255 s, Integer Index, Integer Count); + +/* + * Delete removes Count characters from string S, starting at position Index. + * All characters after the deleted characters are shifted Count positions to the left, + * and the length of the string is adjusted. + */ +#define fpcrtl_delete(s, index, count) fpcrtl_delete__vars(&(s), index, count) +void fpcrtl_delete__vars(string255 *s, SizeInt index, SizeInt count); + +string255 fpcrtl_floatToStr(double n); + +/* + * Move data from one location in memory to another + */ +void fpcrtl_move__vars(void *src, void *dst, SizeInt count); +#define fpcrtl_move(src, dst, count) fpcrtl_move__vars(&(src), &(dst), count); +#define fpcrtl_Move fpcrtl_move + +Integer __attribute__((overloadable)) fpcrtl_pos(Char c, string255 str); +Integer __attribute__((overloadable)) fpcrtl_pos(string255 substr, string255 str); + +Integer fpcrtl_length(string255 s); +#define fpcrtl_Length fpcrtl_length + +#define fpcrtl_sqr(x) ((x) * (x)) + +#define fpcrtl_odd(x) ((x) % 2 != 0 ? true : false) + +#define fpcrtl_StrLen strlen + +#define SizeOf sizeof + +string255 fpcrtl_lowerCase(string255 s); +#define fpcrtl_LowerCase fpcrtl_lowerCase + +void fpcrtl_fillChar__vars(void *x, SizeInt count, Byte value); +#define fpcrtl_fillChar(x, count, value) fpcrtl_fillChar__vars(&(x), count, value) +#define fpcrtl_FillChar fpcrtl_fillChar + +void fpcrtl_new__vars(void **p, int size); +#define fpcrtl_new(a) fpcrtl_new__vars((void **)&(a), sizeof(*(a))) + +#define fpcrtl_dispose free + +#define fpcrtl_freeMem(p, size) free(p) +#define fpcrtl_FreeMem(p, size) free(p) + +#define fpcrtl_getMem(size) malloc(size) +#define fpcrtl_GetMem fpcrtl_getMem + +#define fpcrtl_assigned(p) ((p) != NULL) +#define fpcrtl_Assigned fpcrtl_assigned + +Integer fpcrtl_trunc(extended n); + +#define fpcrtl_val(s, a, c) fpcrtl_val__vars(s, &(a), &(c)) +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongInt *a, LongInt *c); +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, Byte *a, LongInt *c); +void __attribute__((overloadable)) fpcrtl_val__vars(string255 s, LongWord *a, LongInt *c); + +#define fpcrtl_randomize() srand(time(NULL)) + +/* + * Random returns a random number larger or equal to 0 and strictly less than L + */ +LongInt fpcrtl_random(LongInt l); + +string255 fpcrtl_paramStr(LongInt); +#define fpcrtl_ParamStr fpcrtl_paramStr + +/* + * Str returns a string which represents the value of X. X can be any numerical type. + */ +#define fpcrtl_str(x, s) fpcrtl_str__vars(x, &(s)) +void __attribute__((overloadable)) fpcrtl_str__vars(float x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(double x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(uint8_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(int8_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(uint16_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(int16_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(uint32_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(int32_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(uint64_t x, string255 *s); +void __attribute__((overloadable)) fpcrtl_str__vars(int64_t x, string255 *s); + +void fpcrtl_interlockedIncrement__vars(int *i); +void fpcrtl_interlockedDecrement__vars(int *i); + +#define fpcrtl_interlockedIncrement(i) fpcrtl_interlockedIncrement__vars(&(i)) +#define fpcrtl_interlockedDecrement(i) fpcrtl_interlockedDecrement__vars(&(i)) + +#define fpcrtl_InterlockedIncrement fpcrtl_interlockedIncrement +#define fpcrtl_InterlockedDecrement fpcrtl_interlockedDecrement + +void fpcrtl_init(int argc, char** argv); + +int fpcrtl_paramCount(); +#define fpcrtl_ParamCount fpcrtl_paramCount + +string255 fpcrtl_paramStr(int i); +#define fpcrtl_ParamStr fpcrtl_paramStr + +int fpcrtl_UTF8ToUnicode(PWideChar dest, PChar src, SizeInt maxLen); + +#define fpcrtl_halt(t) assert(0) + +#define fpcrtl_Load_GL_VERSION_2_0() 1 + +uint32_t __attribute__((overloadable)) fpcrtl_lo(uint64_t); +#define fpcrtl_Lo fpcrtl_lo + +#define __SET_LENGTH2(arr, d, b) do{\ + d.dim = 1;\ + arr = realloc(arr, b * sizeof(typeof(*arr)));\ + d.a[0] = b;\ + }while(0) + +#define SET_LENGTH2(arr, b) __SET_LENGTH2(arr, arr##_dimension_info, (b)) + +#define __SET_LENGTH3(arr, d, b, c) do{\ + d.dim = 2;\ + for (int i = 0; i < d.a[0]; i++) {\ + arr[i] = realloc(arr[i], c * sizeof(typeof(**arr)));\ + }\ + if (d.a[0] > b) {\ + for (int i = b; i < d.a[0]; i++) {\ + free(arr[i]);\ + }\ + arr = realloc(arr, b * sizeof(typeof(*arr)));\ + } else if (d.a[0] < b) {\ + arr = realloc(arr, b * sizeof(typeof(*arr)));\ + for (int i = d.a[0]; i < b; i++) {\ + arr[i] = malloc(c * sizeof(typeof(**arr)));\ + memset(arr[i], 0, c * sizeof(typeof(**arr)));\ + }\ + }\ + d.a[0] = b;\ + d.a[1] = c;\ + }while(0) + +#define SET_LENGTH3(arr, b, c) __SET_LENGTH3(arr, arr##_dimension_info, (b), (c)) + +#define fpcrtl_SetLength(...) macro_dispatcher(SET_LENGTH, __VA_ARGS__)(__VA_ARGS__) + +#endif /* SYSTEM_H_ */ diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/sysutils.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/sysutils.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,178 @@ +#include "SysUtils.h" + +#include +#include +#include +#include + +#include "system.h" +#include "misc.h" + +TDateTime fpcrtl_date() +{ + const int num_days_between_1900_1980 = 29220; + + struct tm ref_date; + struct tm cur_date; + time_t local_time; + time_t ref_time, cur_time; + + double timeDiff; + double day_time_frac; //fraction that represents the time in one day + int num_seconds; + int numDays; + + // unix epoch doesn't work, choose Jan 1st 1980 instead + ref_date.tm_year = 80; + ref_date.tm_mon = 0; + ref_date.tm_mday = 1; + ref_date.tm_hour = 0; + ref_date.tm_min = 0; + ref_date.tm_sec = 0; + ref_date.tm_isdst = 0; + ref_date.tm_wday = 0; // ignored + ref_date.tm_yday = 0; // ignored + + local_time = time(NULL); + cur_date = *localtime(&local_time); + + cur_date.tm_hour = 0; + cur_date.tm_min = 0; + cur_date.tm_sec = 0; + + ref_time = mktime(&ref_date); + cur_time = mktime(&cur_date); + + timeDiff = difftime(cur_time, ref_time); + numDays = fpcrtl_round(timeDiff / 3600 / 24) + num_days_between_1900_1980 + 1; + + fpcrtl_printf("[date] tim diff: %f\n", timeDiff); + fpcrtl_printf("[date] num days between 1980 and today: %d\n", fpcrtl_round(timeDiff/3600/24)); + fpcrtl_printf("[date] current date: %s\n", asctime(&cur_date)); + fpcrtl_printf("[date] reference date: %s\n", asctime(&ref_date)); + fpcrtl_printf("[date] num days: %d\n", numDays); + + return numDays; +} + +TDateTime fpcrtl_time() +{ + struct tm cur_date; + time_t local_time; + time_t cur_time; + + double day_time_frac; //fraction that represents the time in one day + int num_seconds; + + local_time = time(NULL); + cur_date = *localtime(&local_time); + + num_seconds = cur_date.tm_hour * 3600 + cur_date.tm_min * 60 + cur_date.tm_sec; + day_time_frac = num_seconds / 3600.0 / 24.0; + + fpcrtl_printf("%f\n", day_time_frac); + + return day_time_frac; +} + +TDateTime fpcrtl_now() +{ + return fpcrtl_date() + fpcrtl_time(); +} + +/* + * XXX: dummy + */ +string255 fpcrtl_formatDateTime(string255 FormatStr, TDateTime DateTime) +{ + string255 result = STRINIT("2012 01-01"); + return result; +} + +string255 fpcrtl_trim(string255 s) +{ + int left, right; + + if(s.len == 0){ + return s; + } + + for(left = 0; left < s.len; left++) + { + if(s.str[left] != ' '){ + break; + } + } + + for(right = s.len - 1; right >= 0; right--) + { + if(s.str[right] != ' '){ + break; + } + } + + if(left > right){ + s.len = 0; + s.str[0] = 0; + return s; + } + + s.len = right - left + 1; + memmove(s.str, s.str + left, s.len); + + s.str[s.len] = 0; + + return s; +} + +Integer fpcrtl_strToInt(string255 s) +{ + s.str[s.len] = 0; + return atoi(s.str); +} + +//function ExtractFileName(const FileName: string): string; +//var +// i : longint; +// EndSep : Set of Char; +//begin +// I := Length(FileName); +// EndSep:=AllowDirectorySeparators+AllowDriveSeparators; +// while (I > 0) and not (FileName[I] in EndSep) do +// Dec(I); +// Result := Copy(FileName, I + 1, MaxInt); +//end; + +string255 fpcrtl_extractFileName(string255 f) +{ + const char sep[] = {'\\', '/', ':'}; + LongInt i,j; + + i = f.len - 1; + while(i >= 0){ + for(j = 0; j < sizeof(sep); j++){ + if(f.str[i] == sep[j]){ + goto FPCRTL_EXTRACTFILENAME_END; + } + } + i--; + } +FPCRTL_EXTRACTFILENAME_END: + return fpcrtl_copy(f, i + 2, 256); +} + +string255 fpcrtl_strPas(PChar p) +{ + string255 s; + int l = strlen(p); + + if(l > 255){ + printf("strPas: source string length > 255\n"); + assert(0); + } + + s.len = l; + strcpy(s.str, p); + + return s; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_check.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_check.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,23 @@ +#include +#include +#include "check_check.h" + +int main(void) +{ + int number_failed; + + Suite *s1 = system_suite(); + Suite *s2 = misc_suite(); + Suite *s3 = sysutils_suite(); + Suite *s4 = fileio_suite(); + + SRunner *sr = srunner_create(s1); + srunner_add_suite(sr, s2); + srunner_add_suite(sr, s3); + srunner_add_suite(sr, s4); + + srunner_run_all(sr, CK_NORMAL); + number_failed = srunner_ntests_failed(sr); + srunner_free(sr); + return (number_failed == 0) ? EXIT_SUCCESS : EXIT_FAILURE; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_check.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_check.h Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,9 @@ +#ifndef _CHECK_CHECK_H_ +#define _CHECK_CHECK_H_ + +Suite *system_suite(); +Suite *misc_suite(); +Suite *sysutils_suite(); +Suite *fileio_suite(); + +#endif diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_fileio.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_fileio.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,103 @@ +#include +#include +#include +#include "check_check.h" +#include "../src/fpcrtl.h" + +typedef struct __TResourceList +{ + Integer count; + string255 files[500 + 1]; +} TResourceList; + +string255 t = STRINIT("test"); +string255 Pathz[1] = +{ STRINIT("../../") }; +int ptCurrTheme = 0; +string255 cThemeCFGFilename = STRINIT("theme.cfg"); +const string255 __str79 = STRINIT("object"); +string255 c1 = STRINIT("="); +string255 c2 = STRINIT("\x2c"); +string255 c3 = STRINIT("\x2f"); + +static string255 make_string(const char* str) +{ + string255 s; + s.len = strlen(str); + memcpy(s.str, str, s.len + 1); + return s; +} + +TResourceList readThemeCfg_0() +{ + TResourceList readthemecfg_result; + string255 s; + string255 key; + TextFile f; + Integer i; + TResourceList res; + + s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename); + //umisc_log(s); + + fpcrtl_assign(f, s); + + FileMode = 0; + fpcrtl_reset(f); + + res.count = 0; + while (!(fpcrtl_eof(f))) + { + fpcrtl_readLnS(f, s); + if ((fpcrtl_Length(s)) == (0)) + { + continue; + } + if ((s.s[1]) == ('\x3b')) + { + continue; + } + i = fpcrtl_pos('\x3d', s); + key = fpcrtl_trim(fpcrtl_copy(s, 1, i - 1)); + fpcrtl_delete(s, 1, i); + if (_strcompare(key, __str79)) + { + i = fpcrtl_pos('\x2c', s); + res.files[res.count] = _strconcat( + _strappend(Pathz[ptCurrTheme], '\x2f'), + fpcrtl_trim(fpcrtl_copy(s, 1, i - 1))); + ++res.count; + //umisc_log(fpcrtl_trim(fpcrtl_copy(s, 1, i - 1))); + } + } + fpcrtl_close(f); + readthemecfg_result = res; + return readthemecfg_result; +} + +START_TEST(test_readthemecfg) + { + int i; + TResourceList result; + + printf("-----Entering test readthemecfg-----\n"); + result = readThemeCfg_0(); + for (i = 0; i < result.count; i++) + { + printf("%s\n", result.files[i].str); + } + printf("-----Leaving test readthemecfg-----\n"); + }END_TEST + +Suite* fileio_suite(void) +{ + Suite *s = suite_create("fileio"); + + TCase *tc_core = tcase_create("Core"); + + tcase_add_test(tc_core, test_readthemecfg); + + suite_add_tcase(s, tc_core); + + return s; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_misc.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_misc.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,88 @@ +#include +#include +#include +#include "check_check.h" +#include "../src/misc.h" + +static string255 make_string(const char* str) +{ + string255 s; + s.len = strlen(str); + memcpy(s.str, str, s.len + 1); + return s; +} + +START_TEST(test_strconcat) +{ + string255 t; + t = fpcrtl_strconcat(make_string(""), make_string("")); + fail_if(strcmp(t.str, ""), "strconcat(\"\", \"\")"); + + t = fpcrtl_strconcat(make_string(""), make_string("a")); + fail_if(strcmp(t.str, "a"), "strconcat(\"\", \"a\")"); + + t = fpcrtl_strconcat(make_string("a"), make_string("")); + fail_if(strcmp(t.str, "a"), "strconcat(\"a\", \"\")"); + + t = fpcrtl_strconcat(make_string("ab"), make_string("")); + fail_if(strcmp(t.str, "ab"), "strconcat(\"ab\", \"\")"); + + t = fpcrtl_strconcat(make_string("ab"), make_string("cd")); + fail_if(strcmp(t.str, "abcd"), "strconcat(\"ab\", \"cd\")"); +} +END_TEST + +START_TEST (test_strappend) +{ + string255 t; + + t = fpcrtl_strappend(make_string(""), 'c'); + fail_if(strcmp(t.str, "c"), "strappend(\"\", 'c')"); + + t = fpcrtl_strappend(make_string("ab"), 'c'); + fail_if(strcmp(t.str, "abc"), "strappend(\"ab\", 'c')"); +} +END_TEST + +START_TEST (test_strprepend) +{ + string255 t; + + t = fpcrtl_strprepend('c', make_string("")); + fail_if(strcmp(t.str, "c"), "strprepend('c', \"\")"); + + t = fpcrtl_strprepend('c', make_string("ab")); + fail_if(strcmp(t.str, "cab"), "strprepend('c', \"ab\")"); +} +END_TEST + +START_TEST (test_strcompare) +{ + fail_unless(fpcrtl_strcompare(make_string(""), make_string("")), "strcompare(\"\", \"\")"); + fail_unless(fpcrtl_strcompare(make_string("a"), make_string("a")), "strcompare(\"a\", \"a\""); + fail_unless(!fpcrtl_strcompare(make_string("a"), make_string("b")), "strcompare(\"a\", \"b\")"); + fail_unless(!fpcrtl_strcompare(make_string("a"), make_string("ab")), "strcompare(\"a\", \"ab\")"); + + fail_unless(fpcrtl_strcomparec(make_string(" "), ' '), "strcomparec(\" \", ' ')"); + fail_unless(fpcrtl_strcomparec(make_string("a"), 'a'), "strcomparec(\"a\", 'a')"); + fail_unless(!fpcrtl_strcomparec(make_string(" "), ' '), "strcomparec(\" \", ' '"); + fail_unless(!fpcrtl_strcomparec(make_string(""), ' '), "strcomparec(\"\", ' ')"); + +} +END_TEST + +Suite* misc_suite(void) +{ + Suite *s = suite_create("misc"); + + TCase *tc_core = tcase_create("Core"); + + tcase_add_test(tc_core, test_strconcat); + tcase_add_test(tc_core, test_strappend); + tcase_add_test(tc_core, test_strprepend); + tcase_add_test(tc_core, test_strcompare); + + suite_add_tcase(s, tc_core); + + return s; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_system.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_system.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,251 @@ +#include +#include +#include +#include "check_check.h" +#include "../src/system.h" + +void check_string(string255 str) +{ + fail_unless(strlen(str.str) == str.len, "String internal inconsistency error"); +} + +static string255 make_string(const char* str) +{ + string255 s; + s.len = strlen(str); + memcpy(s.str, str, s.len + 1); + return s; +} + +START_TEST (test_copy) + { + string255 s = STRINIT("1234567"); + string255 t; + + t = fpcrtl_copy(s, 1, 1); + fail_if(strcmp(t.str, "1"), "Test copy fail 1"); + + t = fpcrtl_copy(s, 7, 1); + fail_if(strcmp(t.str, "7"), "Test copy fail 2"); + + t = fpcrtl_copy(s, 8, 1); + fail_if(t.len != 0, "Test copy fail 3"); + + t = fpcrtl_copy(s, 8, 100); + fail_if(t.len != 0, "Test copy fail 4"); + check_string(t); + + t = fpcrtl_copy(s, 0, 100); + fail_if(strcmp(t.str, "1234567"), "Test copy fail 5"); + + t = fpcrtl_copy(s, 0, 5); + fail_if(strcmp(t.str, "12345"), "Test copy fail 6"); + + t = fpcrtl_copy(s, 4, 100); + fail_if(strcmp(t.str, "4567"), "Test copy fail 7"); + + t = fpcrtl_copy(s, 4, 2); + fail_if(strcmp(t.str, "45"), "Test copy fail 8"); + }END_TEST + +START_TEST (test_delete) + { + string255 s = STRINIT("1234567"); + string255 s2 = STRINIT("1234567"); + string255 s3 = STRINIT("1234567"); + + fpcrtl_delete(s, 0, 10); + fail_if(strcmp(s.str, "1234567"), "delete(\"1234567\", 0, 10)"); + check_string(s); + + fpcrtl_delete(s, 1, 1); + fail_if(strcmp(s.str, "234567"), "delete(\"1234567\", 1, 1)"); + check_string(s); + + fpcrtl_delete(s, 1, 100); + fail_if(strcmp(s.str, ""), "delete(\"234567\", 1, 100)"); + check_string(s); + + fpcrtl_delete(s2, 3, 2); + fail_if(strcmp(s2.str, "12567"), "delete(\"1234567\", 3, 2)"); + check_string(s2); + + fpcrtl_delete(s3, 3, 100); + fail_if(strcmp(s3.str, "12"), "delete(\"1234567\", 3, 100)"); + check_string(s3); + + } +END_TEST + +START_TEST (test_FloatToStr) + { + double s = 1.2345; + string255 t = fpcrtl_floatToStr(s); + printf("-----Entering test floatToStr-----\n"); + printf("FloatToStr(%f) = %s\n", s, t.str); + printf("-----Leaving test floatToStr-----\n"); + } +END_TEST + +START_TEST (test_random) + { + fpcrtl_randomize(); + printf("-----Entering test random-----\n"); + printf("random(5000) = %d\n", fpcrtl_random(5000)); + printf("random(1) = %d\n", fpcrtl_random(1)); + printf("random(2) = %d\n", fpcrtl_random(2)); + printf("-----Leaving test random-----\n"); + + } +END_TEST + +START_TEST (test_posS) + { + string255 substr1 = STRINIT("123"); + string255 str1 = STRINIT("12345"); + + string255 substr2 = STRINIT("45"); + string255 str2 = STRINIT("12345"); + + string255 substr3 = STRINIT(""); + string255 str3 = STRINIT("12345"); + + string255 substr4 = STRINIT("123"); + string255 str4 = STRINIT(""); + + string255 substr5 = STRINIT("123"); + string255 str5 = STRINIT("456"); + + fail_unless(fpcrtl_posS(substr1, str1) == 1, "pos(123, 12345)"); + fail_unless(fpcrtl_posS(substr2, str2) == 4, "pos(45, 12345)"); + fail_unless(fpcrtl_posS(substr3, str3) == 0, "pos(, 12345)"); + fail_unless(fpcrtl_posS(substr4, str4) == 0, "pos(123, )"); + fail_unless(fpcrtl_posS(substr5, str5) == 0, "pos(123, 456)"); + } +END_TEST + +START_TEST (test_trunc) + { + fail_unless(fpcrtl_trunc(123.456) == 123, "trunc(123.456)"); + fail_unless(fpcrtl_trunc(-123.456) == -123, "trunc(-123.456)"); + fail_unless(fpcrtl_trunc(12.3456) == 12, "trunc(12.3456)"); + fail_unless(fpcrtl_trunc(-12.3456) == -12, "trunc(-12.3456)"); + } +END_TEST + +START_TEST (test_odd) +{ + fail_unless(fpcrtl_odd(123) != 0, "odd(123)"); + fail_unless(fpcrtl_odd(124) == 0, "odd(124)"); + fail_unless(fpcrtl_odd(0) == 0, "odd(0)"); + fail_unless(fpcrtl_odd(-1) != 0, "odd(-1)"); + fail_unless(fpcrtl_odd(-2) == 0, "odd(-2)"); +} +END_TEST + +START_TEST (test_sqr) +{ + fail_unless(fpcrtl_sqr(0) == 0, "sqr(0)"); + fail_unless(fpcrtl_sqr(5) == 25, "sqr(5)"); + fail_unless(fpcrtl_sqr(-5) == 25, "sqr(-5)"); +} +END_TEST + +START_TEST (test_lowercase) +{ + string255 s1 = STRINIT(""); + string255 s2 = STRINIT("a"); + string255 s3 = STRINIT("abc"); + string255 t; + + t = fpcrtl_lowerCase(make_string("")); + fail_if(strcmp(t.str, s1.str), "lowerCase(\"\")"); + + t = fpcrtl_lowerCase(make_string("a")); + fail_if(strcmp(t.str, s2.str), "lowerCase(\"a\")"); + + t = fpcrtl_lowerCase(make_string("A")); + fail_if(strcmp(t.str, s2.str), "lowerCase(\"A\")"); + + t = fpcrtl_lowerCase(make_string("AbC")); + fail_if(strcmp(t.str, s3.str), "lowerCase(\"AbC\")"); + + t = fpcrtl_lowerCase(make_string("abc")); + fail_if(strcmp(t.str, s3.str), "lowerCase(\"abc\")"); +} +END_TEST + +START_TEST (test_str) +{ + int8_t a1 = -8; + uint8_t a2 = 8; + int16_t a3 = -13; + uint16_t a4 = 13; + int32_t a5 = -19; + uint32_t a6 = 22; + int64_t a7 = -199999999999999; + uint64_t a8 = 200000000000000; + + float a9 = 12345.6789; + double a10 = -9876.54321; + + string255 s; + + printf("-----Entering test str-----\n"); + + fpcrtl_str(a1, s); + printf("%d == %s\n", a1, s.str); + + fpcrtl_str(a2, s); + printf("%u == %s\n", a2, s.str); + + fpcrtl_str(a3, s); + printf("%d == %s\n", a3, s.str); + + fpcrtl_str(a4, s); + printf("%u == %s\n", a4, s.str); + + fpcrtl_str(a5, s); + printf("%d == %s\n", a5, s.str); + + fpcrtl_str(a6, s); + printf("%u == %s\n", a6, s.str); + + fpcrtl_str(a7, s); + printf("%lld == %s\n", a7, s.str); + + fpcrtl_str(a8, s); + printf("%llu == %s\n", a8, s.str); + + fpcrtl_str(a9, s); + printf("%f == %s\n", a9, s.str); + + fpcrtl_str(a10, s); + printf("%f == %s\n", a10, s.str); + + printf("-----Leaving test str------\n"); +} +END_TEST + +Suite* system_suite(void) +{ + Suite *s = suite_create("system"); + + TCase *tc_core = tcase_create("Core"); + + tcase_add_test(tc_core, test_copy); + tcase_add_test(tc_core, test_FloatToStr); + tcase_add_test(tc_core, test_random); + tcase_add_test(tc_core, test_posS); + tcase_add_test(tc_core, test_trunc); + tcase_add_test(tc_core, test_delete); + tcase_add_test(tc_core, test_odd); + tcase_add_test(tc_core, test_sqr); + tcase_add_test(tc_core, test_lowercase); + tcase_add_test(tc_core, test_str); + + suite_add_tcase(s, tc_core); + + return s; +} + diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/check_sysutils.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/check_sysutils.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,80 @@ +#include +#include +#include +#include "check_check.h" +#include "../src/sysutils.h" + +static string255 make_string(const char* str) +{ + string255 s; + s.len = strlen(str); + memcpy(s.str, str, s.len + 1); + return s; +} + +static int is_string_equal(string255 s1, string255 s2) +{ + return (s1.len == s2.len) && (strcmp(s1.str, s2.str) == 0); +} + +START_TEST (test_trim) +{ + string255 t; + + t = fpcrtl_trim(make_string("")); + fail_if(strcmp(t.str, ""), "trim(\"\")"); + + t = fpcrtl_trim(make_string("ab")); + fail_if(strcmp(t.str, "ab"), "trim(\"ab\")"); + + t = fpcrtl_trim(make_string(" ")); + fail_if(strcmp(t.str, ""), "trim(\" \")"); + + t = fpcrtl_trim(make_string(" ")); + fail_if(strcmp(t.str, ""), "trim(\" \")"); + + t = fpcrtl_trim(make_string(" ab")); + fail_if(strcmp(t.str, "ab"), "trim(\" ab\")"); + + t = fpcrtl_trim(make_string("ab ")); + fail_if(strcmp(t.str, "ab"), "trim(\"ab \")"); + + t = fpcrtl_trim(make_string(" ab ")); + fail_if(strcmp(t.str, "ab"), "trim(\" ab \")"); + +} +END_TEST + +START_TEST (test_strToInt) +{ + fail_unless(fpcrtl_strToInt(make_string("123")) == 123, "strToInt(\"123\")"); + fail_unless(fpcrtl_strToInt(make_string("0")) == 0, "strToInt(\"0\")"); + fail_unless(fpcrtl_strToInt(make_string("-123")) == -123, "strToInt(\"-123\")"); +} +END_TEST + +START_TEST (test_extractFileName) +{ + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("abc")), make_string("abc")), "extractFileName(\"abc\")"); + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("a:abc")), make_string("abc")), "extractFileName(\"a:abc\")"); + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("/abc")), make_string("abc")), "extractFileName(\"/abc\")"); + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("\\abc")), make_string("abc")), "extractFileName(\"\\abc\")"); + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("/usr/bin/abc")), make_string("abc")), "extractFileName(\"/usr/bin/abc\")"); + fail_unless(is_string_equal(fpcrtl_extractFileName(make_string("c:\\def\\abc")), make_string("abc")), "extractFileName(\"c:\\def\\abc\")"); +} +END_TEST + +Suite* sysutils_suite(void) +{ + Suite *s = suite_create("sysutils"); + + TCase *tc_core = tcase_create("Core"); + + tcase_add_test(tc_core, test_trim); + tcase_add_test(tc_core, test_strToInt); + tcase_add_test(tc_core, test_extractFileName); + + suite_add_tcase(s, tc_core); + + return s; +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/fileio_test.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/fileio_test.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,59 @@ + +#include "pas2c.h" + +#include "fpcrtl.h" + +char Pathz[1][128] = {"./"}; +int ptCurrTheme = 0; +cThemeCFGFilename = "theme.cfg"; +const string255 __str79 = STRINIT("object"); + +typedef struct __TResourceList { + Integer count; + string255 files[500 + 1]; +} TResourceList; + +TResourceList readThemeCfg_0() +{ + TResourceList readthemecfg_result; + string255 s; + string255 key; + TextFile f; + Integer i; + TResourceList result; + s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename); + + assign(f, s); + FileMode = 0; + reset(f); + result.count = 0; + while(!eof(f)) + { + readLnS(f, s); + if((Length(s)) == (0)) + { + continue; + } + if((s.s[1]) == ('\x3b')) + { + continue; + } + i = pos('\x3d', s); + key = trim(copy(s, 1, i - 1)); + delete(s, 1, i); + if(_strcompare(key, __str79)) + { + i = pos('\x2c', s); + result.files[result.count] = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), trim(copy(s, 1, i - 1))); + ++result.count; + } + } + close(f); + readthemecfg_result = result; + return readthemecfg_result; +}; + +int main(int argc, char** argv) +{ + readThemeCfg_0(); +} diff -r 2286a39140da -r 453917e94e55 project_files/hwc/rtl/tests/main.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/project_files/hwc/rtl/tests/main.c Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,84 @@ + +//#include +//#include "fpcrtl.h" +//#include "fileio.h" +// +//string255 t = STRINIT("test"); +//string255 Pathz[1] = {STRINIT(".")}; +////int ptCurrTheme = 0; +//string255 cThemeCFGFilename = STRINIT("theme.cfg"); +//const string255 __str79 = STRINIT("object"); +//string255 c1 = STRINIT("="); +//string255 c2 = STRINIT("\x2c"); +//string255 c3 = STRINIT("\x2f"); +// +//typedef struct __TResourceList { +// Integer count; +// string255 files[500 + 1]; +//} TResourceList; +// +//TResourceList readThemeCfg_0() +//{ +// TResourceList readthemecfg_result; +// string255 s; +// string255 key; +// TextFile f; +// Integer i; +// TResourceList result; +// +// int t = 0; +// +// s = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), cThemeCFGFilename); +// +// assign(&f, s); +// +// reset(&f); +// +// if(f.fp == NULL){ +// readthemecfg_result.count = 0; +// return readthemecfg_result; +// } +// +// result.count = 0; +// while(!eof(&f)) +// { +// readLnS(&f, &s); +// +// if((Length(s)) == (0)) +// { +// continue; +// } +// if((s.s[1]) == ('\x3b')) +// { +// continue; +// } +// +// i = pos(c1, s); +// +// key = fpcrtl_trim(fpcrtl_copy(s, 1, i - 1)); +// +// fpcrtl_delete(&s, 1, i); +// +// if(_strcompare(key, __str79)) +// { +// i = pos(c2, s); +// result.files[result.count] = _strconcat(_strappend(Pathz[ptCurrTheme], '\x2f'), trim(copy(s, 1, i - 1))); +// ++result.count; +// } +// } +// +// close(&f); +// readthemecfg_result = result; +// return readthemecfg_result; +//} +// +int main(int argc, char** argv) +{ + int i; + +// TResourceList result = readThemeCfg_0(); +// for(i = 0; i < result.count; i++){ +// printf("%s\n", result.files[i].str); +// } + +} diff -r 2286a39140da -r 453917e94e55 share/CMakeLists.txt diff -r 2286a39140da -r 453917e94e55 tools/PascalBasics.hs --- a/tools/PascalBasics.hs Wed Nov 21 23:34:54 2012 +0100 +++ /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) diff -r 2286a39140da -r 453917e94e55 tools/PascalParser.hs --- a/tools/PascalParser.hs Wed Nov 21 23:34:54 2012 +0100 +++ /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) - diff -r 2286a39140da -r 453917e94e55 tools/PascalPreprocessor.hs --- a/tools/PascalPreprocessor.hs Wed Nov 21 23:34:54 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,135 +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", "") - , ("S3D_DISABLED", "") - ] - -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 ++ "}" diff -r 2286a39140da -r 453917e94e55 tools/PascalUnitSyntaxTree.hs --- a/tools/PascalUnitSyntaxTree.hs Wed Nov 21 23:34:54 2012 +0100 +++ /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 diff -r 2286a39140da -r 453917e94e55 tools/pas2c.hs --- a/tools/pas2c.hs Wed Nov 21 23:34:54 2012 +0100 +++ /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 "<>" -initExpr2C' (InitSet []) = return $ text "0" -initExpr2C' (InitSet a) = return $ text "<>" -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 "<>" <+>) - 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 - diff -r 2286a39140da -r 453917e94e55 tools/pas2c/CMakeLists.txt --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/CMakeLists.txt Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,29 @@ +set(pas2c_sources + Main.hs + PascalBasics.hs + PascalParser.hs + PascalPreprocessor.hs + PascalUnitSyntaxTree.hs + Pas2C.hs + ) + +set(pas2c_main ${CMAKE_SOURCE_DIR}/tools/pas2c/Main.hs) + +set(ghc_flags + --make ${pas2c_main} + -i${CMAKE_SOURCE_DIR}/tools/pas2c/ + -o ${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX} + -odir ${CMAKE_CURRENT_BINARY_DIR} + -hidir ${CMAKE_CURRENT_BINARY_DIR} + ${haskell_flags} + ) + +add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}" + COMMAND "${ghc_executable}" + ARGS ${ghc_flags} + MAIN_DEPENDENCY ${hwserv_main} + DEPENDS ${hwserver_sources} + ) + +add_custom_target(pas2c ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}") + diff -r 2286a39140da -r 453917e94e55 tools/pas2c/Main.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/Main.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,56 @@ +module Main( main ) where + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Data.Maybe( fromMaybe ) +import Pas2C + +main = do + args <- getArgs + if length args == 0 + then do + name <- getProgName + hPutStrLn stderr $ usageInfo header options + exitFailure + else do + case getOpt RequireOrder options args of + (flags, [], []) -> + if length args == 8 then do + hPutStrLn stdout $ "--------Pas2C Config--------" + hPutStrLn stdout $ "Main module: " ++ (args !! 1) + hPutStrLn stdout $ "Input path : " ++ (args !! 3) + hPutStrLn stdout $ "Output path: " ++ (args !! 5) + hPutStrLn stdout $ "Altern path: " ++ (args !! 7) + hPutStrLn stdout $ "----------------------------" + pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") ((args !! 7)++"/") + hPutStrLn stdout $ "----------------------------" + else do + if length args == 6 then do + hPutStrLn stdout $ "--------Pas2C Config--------" + hPutStrLn stdout $ "Main module: " ++ (args !! 1) + hPutStrLn stdout $ "Input path : " ++ (args !! 3) + hPutStrLn stdout $ "Output path: " ++ (args !! 5) + hPutStrLn stdout $ "Altern path: " ++ "./" + hPutStrLn stdout $ "----------------------------" + pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") "./" + hPutStrLn stdout $ "----------------------------" + else do + error $ usageInfo header options + (_, nonOpts, []) -> error $ "unrecognized arguments: " ++ unwords nonOpts + (_, _, msgs) -> error $ usageInfo header options + where header = "Freepascal to C conversion! Please use -n -i -o -a options in this order.\n" + + +data Flag = HelpMessage | Name String | Input String | Output String | Alternate String + +options :: [OptDescr Flag] +options = [ + Option ['h'] ["help"] (NoArg HelpMessage) "print this help message", + Option ['n'] ["name"] (ReqArg Name "MAIN") "name of the main Pascal module", + Option ['i'] ["input"] (ReqArg Input "DIR") "input directory, where .pas files will be read", + Option ['o'] ["output"] (ReqArg Output "DIR") "output directory, where .c/.h files will be written", + Option ['a'] ["alternate"] (ReqArg Alternate "DIR") "alternate input directory, for out of source builds" + ] + diff -r 2286a39140da -r 453917e94e55 tools/pas2c/Pas2C.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/Pas2C.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,1172 @@ +{-# 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, + isFunctionType :: Bool, -- set to true if the current function parameter is functiontype + lastIdTypeDecl :: Doc, + stringConsts :: [(String, String)], + uniqCounter :: Int, + toMangle :: Set.Set String, + enums :: [(String, [String])], -- store all declared enums + currentUnit :: String, + currentFunctionResult :: String, + namespaces :: Map.Map String Records + } + +rec2Records = map (\(a, b) -> Record a b empty) + +emptyState = RenderState Map.empty "" BTUnknown False 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 -> String -> String -> String -> IO () +pas2C fn inputPath outputPath alternateInputPath = do + s <- flip execStateT initState $ f fn + renderCFiles s outputPath + 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 inputPath alternateInputPath (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 (outputPath ++ "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 -> String -> IO () +renderCFiles units outputPath = 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 outputPath 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 :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () +toCFiles _ _ (_, System _) = return () +toCFiles _ _ (_, Redo _) = return () +toCFiles outputPath ns p@(fn, pu) = do + hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." + toCFiles' p + where + toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ 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 ++ "_"} + enumDecl = (renderEnum2Strs (enums s) False) + enumImpl = (renderEnum2Strs (enums s) True) + writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl + writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl + initialState = emptyState ns + + render2C :: RenderState -> State RenderState Doc -> String + render2C st p = + let (a, s) = runState p st in + render a + +renderEnum2Strs :: [(String, [String])] -> Bool -> String +renderEnum2Strs enums implement = + render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums + where + decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar") + enum2strBlock en = + text "{" + $+$ + (nest 4 $ + text "switch(enumvar){" + $+$ + (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) + $+$ + text "default: assert(0);" + $+$ + (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") + $+$ + text "}" + ) + $+$ + text "}" + +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 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))) + + 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 (length 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 _) _) = (length 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) + +typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)] +typeVarDecl2BaseType d = do + st <- get + result <- sequence $ concat $ map resolveType' d + put st -- restore state (not sure if necessary) + return result + where + resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)] + resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) + resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" + resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType) + resolveTypeHelper' st b = do + bt <- st + return (b, bt) + +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 "uinteger" = BTInt False + f "integer" = BTInt True + 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 True) t' +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 +resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) +resolveType (DeriveType (InitNumber _)) = return (BTInt True) +resolveType (DeriveType (InitFloat _)) = return BTFloat +resolveType (DeriveType (InitString _)) = return BTString +resolveType (DeriveType (InitBinOp {})) = return (BTInt True) +resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType +resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) +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 overload 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 + 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 bt) inline overload returnType params (Just (tvars, phrase))) = do + let isVoid = case returnType of + VoidType -> True + _ -> False + + let res = docToLower $ text rv <> if isVoid then empty else text "_result" + t <- type2C returnType + t' <- gets lastType + + bts <- typeVarDecl2BaseType params + cu <- gets currentUnit + notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope + + n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars 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 + , 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 inlineDecor = if inline then case notDeclared of + True -> text "static inline" + False -> text "inline" + else empty + overloadDecor = if overload then text "__attribute__((overloadable))" else empty + return [ + --define + -- $+$ + --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ + inlineDecor <+> t empty <+> overloadDecor <+> text 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 + let res = if includeType then [text "typedef" <+> tp i] else [] + case t of + (Sequence ids) -> do + modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s}) + return res + _ -> return res + +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 False 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) = do + modify(\s -> s{lastType = (BTInt True)}) + 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 "<>" +initExpr2C' (InitSet []) = return $ text "0" +initExpr2C' (InitSet a) = return $ text "<>" +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 "<>" <+>) + 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 True +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 (if up then "<=" else ">=") <+> 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 [(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)) + + -- for function/procedure comparision + ("==", BTVoid, _) -> procCompare expr1 expr2 "==" + ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "==" + + ("!=", BTVoid, _) -> 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)) + ("&", 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 False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1 + _ -> parens e1 + e2' <- return $ case (o, t1, t2) of + ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2 + _ -> parens e2 + return $ e1' <+> o' <+> e2' + where + boolOps = ["==", "!=", "<", ">", "<=", ">="] + procCompare expr1 expr2 op = + case (expr1, expr2) of + (Reference r1, Reference r2) -> do + id1 <- ref2C r1 + id2 <- ref2C r2 + return $ (parens id1) <+> text op <+> (parens id2) + (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 + +expr2C (NumberLiteral s) = do + modify(\s -> s{lastType = BTInt True}) + 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) = do + isfunc <- gets isFunctionType + modify(\s -> s{isFunctionType = False}) -- reset + if isfunc then ref2CF ref False else ref2CF ref True +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" _))) = do + e'<- expr2C e + return $ text "(int)" <> parens e' <> text " - 1" +expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do + e' <- expr2C e + lt <- gets lastType + modify (\s -> s{lastType = BTInt True}) + 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 -> Bool -> State RenderState Doc +ref2CF (SimpleReference name) addParens = do + i <- id2C IOLookup name + t <- gets lastType + case t of + BTFunction _ _ rt -> do + modify(\s -> s{lastType = rt}) + return $ if addParens then i <> parens empty else i --xymeng: removed parens + _ -> return $ i +ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do + i <- ref2C r + t <- gets lastType + case t of + BTFunction _ _ rt -> do + modify(\s -> s{lastType = rt}) + return $ if addParens then i <> parens empty else i + _ -> 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 _ 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 + mapM expr2CHelper (zip params bts) + else 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 ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t + where + fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name + fref2C a = ref2C a + expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc + 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 + +ref2C (Address ref) = do + r <- ref2C ref + lt <- gets lastType + case lt of + BTFunction True _ _ -> return $ text "&" <> parens r + _ -> 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 + diff -r 2286a39140da -r 453917e94e55 tools/pas2c/PascalBasics.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/PascalBasics.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,70 @@ +{-# 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 "_" + , opLetter = letter + , 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 + , 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) diff -r 2286a39140da -r 453917e94e55 tools/pas2c/PascalParser.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/PascalParser.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,672 @@ +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 + + fixInit v = concat $ map (\x -> case x of + VarDeclaration a b (ids, t) c -> + let typeId = (Identifier ((\(Identifier i _) -> i) (head ids) ++ "_tt") BTUnknown) in + let res = [TypeDeclaration typeId t, VarDeclaration a b (ids, (SimpleType typeId)) c] in + case t of + RecordType _ _ -> res -- create a separated type declaration + ArrayDecl _ _ -> res + _ -> [x] + _ -> error ("checkInit:\n" ++ (show v))) v + + varSection = do + try $ string "var" + comments + v <- varsDecl1 True "variable declaration" + comments + return $ fixInit v + + constSection = do + try $ string "const" + comments + c <- constsDecl "const declaration" + comments + return $ fixInit 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) + decorators <- many functionDecorator + let inline = any (== "inline;") decorators + overload = any (== "overload;") decorators + b <- if isImpl && (not forward) then + liftM Just functionBody + else + return Nothing + return $ [FunctionDeclaration i inline overload 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 (reservedOp pas "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) + diff -r 2286a39140da -r 453917e94e55 tools/pas2c/PascalPreprocessor.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/PascalPreprocessor.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,138 @@ +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", "") +-- , ("WEBGL", "") +-- , ("AI_MAINTHREAD", "") + , ("ENDIAN_LITTLE", "") + , ("S3D_DISABLED", "") + ] + +preprocess :: String -> String -> String -> IO String +preprocess inputPath alternateInputPath fn = do + r <- runParserT (preprocessFile (inputPath ++ 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 (inputPath ++ fn) `catch` (\exc -> readFile (alternateInputPath ++ 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 ++ "}" diff -r 2286a39140da -r 453917e94e55 tools/pas2c/PascalUnitSyntaxTree.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/PascalUnitSyntaxTree.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,119 @@ +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 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 Bool -- second param indicates whether signed or not + | BTBool + | BTFloat + | BTRecord String [(String, BaseType)] + | BTArray Range BaseType BaseType + | BTFunction Bool [(Bool, BaseType)] BaseType -- (Bool, BaseType), Bool indiciates whether var or not + | BTPointerTo BaseType + | BTUnresolved String + | BTSet BaseType + | BTEnum [String] + | BTVoid + | BTUnit + | BTVarParam BaseType + deriving Show diff -r 2286a39140da -r 453917e94e55 tools/pas2c/unitCycles.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/pas2c/unitCycles.hs Thu Nov 22 00:41:53 2012 +0100 @@ -0,0 +1,46 @@ +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 diff -r 2286a39140da -r 453917e94e55 tools/unitCycles.hs --- a/tools/unitCycles.hs Wed Nov 21 23:34:54 2012 +0100 +++ /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