--- a/.hgignore Sun Nov 11 08:45:51 2012 -0500
+++ b/.hgignore Sun Nov 11 15:14:18 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*
--- a/CMakeLists.txt Sun Nov 11 08:45:51 2012 -0500
+++ b/CMakeLists.txt Sun Nov 11 15:14:18 2012 +0100
@@ -53,8 +53,11 @@
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(ANDROID "Enable Android build [default: off]" OFF)
+option(WEBGL "Enable WebGL build (implies NOPASCAL) [default: off]" OFF)
+option(LIBENGINE "Enable hwengine library [default: off]" OFF)
+
+option(NOPASCAL "Compile hwengine as native C [default: off]" ${WEBGL})
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)
@@ -210,8 +213,8 @@
set(LIBRARY_OUTPUT_PATH ${EXECUTABLE_OUTPUT_PATH})
-#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()
@@ -219,50 +222,69 @@
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(STATUS "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 -- this works everywhere, right?
set(pascal_flags "-k${EXECUTABLE_OUTPUT_PATH}/lib${LUA_LIBRARY}.a" "-k-lreadline" ${pascal_flags})
endif()
-#main engine
-add_subdirectory(hedgewars)
-
-#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 (BUILD_ENGINE_LIBRARY OR ANDROID))
- add_subdirectory(bin)
- add_subdirectory(misc/quazip)
- add_subdirectory(QTfrontend)
- add_subdirectory(share)
- add_subdirectory(tools)
+if(WEBGL)
+ #WEBGL deps
+else()
+ #Android related build scripts
+ if(ANDROID)
+ add_subdirectory(project_files/Android-build)
+ endif()
+
+ #TODO: when ANDROID, LIBENGINE should be set
+ if(NOT (LIBENGINE OR ANDROID))
+ add_subdirectory(bin)
+ add_subdirectory(misc/quazip)
+ add_subdirectory(QTfrontend)
+ add_subdirectory(share)
+ add_subdirectory(tools)
+ endif()
endif()
+
# CPack variables
set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "Hedgewars, a free turn-based strategy")
set(CPACK_PACKAGE_VENDOR "Hedgewars Project")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cmake_modules/FindGLEW.cmake Sun Nov 11 15:14:18 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
--- a/gameServer/hedgewars-server.cabal Sun Nov 11 08:45:51 2012 -0500
+++ b/gameServer/hedgewars-server.cabal Sun Nov 11 15:14:18 2012 +0100
@@ -16,7 +16,6 @@
Build-depends:
base >= 4.3,
- unix,
containers,
vector,
bytestring,
--- a/hedgewars/CMakeLists.txt Sun Nov 11 08:45:51 2012 -0500
+++ b/hedgewars/CMakeLists.txt Sun Nov 11 15:14:18 2012 +0100
@@ -79,7 +79,7 @@
${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(pascal_flags "-dHWLIBRARY" ${pascal_flags})
@@ -97,7 +97,7 @@
if (APPLE)
set(engine_output_name "hwengine.dylib")
endif (APPLE)
-endif(BUILD_ENGINE_LIBRARY)
+endif(LIBENGINE)
IF(FPC)
set(fpc_executable ${FPC})
@@ -133,7 +133,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
@@ -143,7 +143,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")
@@ -217,11 +217,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()
--- a/hedgewars/GL.h Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-#pragma once
-
-#include <GL/gl.h>
--- a/hedgewars/Math.h Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,2 +0,0 @@
-#pragma once
-
--- a/hedgewars/SDLMain.h Sun Nov 11 08:45:51 2012 -0500
+++ /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 <dwaliss1@purdue.edu>
- Non-NIB-Code & other changes: Max Horn <max@quendi.de>
-
- Feel free to customize this file to suit your needs
-*/
-
-#ifndef _SDLMain_h_
-#define _SDLMain_h_
-
-#import <Cocoa/Cocoa.h>
-
-@interface SDLMain : NSObject
-@end
-
-#endif /* _SDLMain_h_ */
--- a/hedgewars/SDLMain.m Sun Nov 11 08:45:51 2012 -0500
+++ /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 <dwaliss1@purdue.edu>
- Non-NIB-Code & other changes: Max Horn <max@quendi.de>
-
- Feel free to customize this file to suit your needs
-*/
-
-#include "SDL.h"
-#include "SDLMain.h"
-#include <sys/param.h> /* for MAXPATHLEN */
-#include <unistd.h>
-
-/* 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;
-}
-
--- a/hedgewars/avwrapper.c Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,515 +0,0 @@
-/*
- * Hedgewars, a free turn based strategy game
- * Copyright (c) 2004-2012 Andrey Korotaev <unC0Rr@gmail.com>
- *
- * 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 <stdlib.h>
-#include <stdio.h>
-#include <stdint.h>
-#include <string.h>
-#include <stdarg.h>
-#include "libavformat/avformat.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;
-
-/*
-Initially I wrote code for latest ffmpeg, but on Linux (Ubuntu)
-only older version is available from repository. That's why you see here
-all of this #if LIBAVCODEC_VERSION_MAJOR < 54.
-Actually, it may be possible to remove code for newer version
-and use only code for older version.
-*/
-
-#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, ...)
-{
- const 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)
-{
- const char Buffer[1024];
-
- vsnprintf(Buffer, 1024, pFmt, VaArgs);
- AddFileLogRaw(Buffer);
-}
-
-static void Log(const char* pFmt, ...)
-{
- const 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 >= 54
- 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 >= 54
- 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 >= 54
- 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 < 54
- // 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);
-}
Binary file hedgewars/hwengine.ico has changed
--- a/hedgewars/hwengine.pas Sun Nov 11 08:45:51 2012 -0500
+++ b/hedgewars/hwengine.pas Sun Nov 11 15:14:18 2012 +0100
@@ -19,7 +19,7 @@
{$INCLUDE "options.inc"}
{$IFDEF WIN32}
-{$R hwengine.rc}
+{$R res/hwengine.rc}
{$ENDIF}
{$IFDEF HWLIBRARY}
--- a/hedgewars/hwengine.rc Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-MAINICON ICON "hwengine.ico"
\ No newline at end of file
--- a/hedgewars/pas2c.h Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,144 +0,0 @@
-#pragma once
-
-#include <stddef.h>
-#include <stdint.h>
-#include <stdbool.h>
-#include <wchar.h>
-
-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);
Binary file hedgewars/res/hwengine.ico has changed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/res/hwengine.rc Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,1 @@
+MAINICON ICON "res/hwengine.ico"
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/sdlmain_osx/SDLMain.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,16 @@
+/* SDLMain.m - main entry point for our Cocoa-ized SDL app
+ Initial Version: Darrell Walisser <dwaliss1@purdue.edu>
+ Non-NIB-Code & other changes: Max Horn <max@quendi.de>
+
+ Feel free to customize this file to suit your needs
+*/
+
+#ifndef _SDLMain_h_
+#define _SDLMain_h_
+
+#import <Cocoa/Cocoa.h>
+
+@interface SDLMain : NSObject
+@end
+
+#endif /* _SDLMain_h_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/sdlmain_osx/SDLMain.m Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,385 @@
+/* SDLMain.m - main entry point for our Cocoa-ized SDL app
+ Initial Version: Darrell Walisser <dwaliss1@purdue.edu>
+ Non-NIB-Code & other changes: Max Horn <max@quendi.de>
+
+ Feel free to customize this file to suit your needs
+*/
+
+#include "SDL.h"
+#include "SDLMain.h"
+#include <sys/param.h> /* for MAXPATHLEN */
+#include <unistd.h>
+
+/* 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;
+}
+
--- a/hedgewars/uSound.pas Sun Nov 11 08:45:51 2012 -0500
+++ b/hedgewars/uSound.pas Sun Nov 11 15:14:18 2012 +0100
@@ -170,7 +170,7 @@
procedure InitSound;
const channels: LongInt = {$IFDEF MOBILE}1{$ELSE}2{$ENDIF};
begin
- if not isSoundEnabled then
+ if (not isSoundEnabled) then
exit;
WriteToConsole('Init sound...');
isSoundEnabled:= SDL_InitSubSystem(SDL_INIT_AUDIO) >= 0;
@@ -268,7 +268,7 @@
if (voicepack^.chunks[snd] = nil) and (Soundz[snd].Path = ptVoices) and (Soundz[snd].FileName <> '') then
begin
s:= UserPathz[Soundz[snd].Path] + '/' + voicepack^.name + '/' + Soundz[snd].FileName;
- if not FileExists(s) then
+ if (not FileExists(s)) then
s:= Pathz[Soundz[snd].Path] + '/' + voicepack^.name + '/' + Soundz[snd].FileName;
if (not FileExists(s)) and (snd in [sndFirePunch2, sndFirePunch3, sndFirePunch4, sndFirePunch5, sndFirePunch6]) then
s:= Pathz[Soundz[sndFirePunch1].Path] + '/' + voicepack^.name + '/' + Soundz[snd].FileName;
@@ -286,7 +286,7 @@
if (defVoicepack^.chunks[snd] = nil) and (Soundz[snd].Path <> ptVoices) and (Soundz[snd].FileName <> '') then
begin
s:= UserPathz[Soundz[snd].Path] + '/' + Soundz[snd].FileName;
- if not FileExists(s) then
+ if (not FileExists(s)) then
s:= Pathz[Soundz[snd].Path] + '/' + Soundz[snd].FileName;
WriteToConsole(msgLoading + s + ' ');
defVoicepack^.chunks[snd]:= Mix_LoadWAV_RW(SDL_RWFromFile(Str2PChar(s), _P'rb'), 1);
@@ -370,7 +370,7 @@
if (voicepack^.chunks[snd] = nil) and (Soundz[snd].Path = ptVoices) and (Soundz[snd].FileName <> '') then
begin
s:= UserPathz[Soundz[snd].Path] + '/' + voicepack^.name + '/' + Soundz[snd].FileName;
- if not FileExists(s) then
+ if (not FileExists(s)) then
s:= Pathz[Soundz[snd].Path] + '/' + voicepack^.name + '/' + Soundz[snd].FileName;
WriteToConsole(msgLoading + s + ' ');
voicepack^.chunks[snd]:= Mix_LoadWAV_RW(SDL_RWFromFile(Str2PChar(s), _P'rb'), 1);
@@ -386,7 +386,7 @@
if (defVoicepack^.chunks[snd] = nil) and (Soundz[snd].Path <> ptVoices) and (Soundz[snd].FileName <> '') then
begin
s:= UserPathz[Soundz[snd].Path] + '/' + Soundz[snd].FileName;
- if not FileExists(s) then
+ if (not FileExists(s)) then
s:= Pathz[Soundz[snd].Path] + '/' + Soundz[snd].FileName;
WriteToConsole(msgLoading + s + ' ');
defVoicepack^.chunks[snd]:= Mix_LoadWAV_RW(SDL_RWFromFile(Str2PChar(s), _P'rb'), 1);
@@ -402,7 +402,7 @@
procedure StopSound(snd: TSound);
begin
- if not isSoundEnabled then
+ if (not isSoundEnabled) then
exit;
if (lastChan[snd] <> -1) and (Mix_Playing(lastChan[snd]) <> 0) then
@@ -414,7 +414,7 @@
procedure StopSoundChan(chn: LongInt);
begin
- if not isSoundEnabled then
+ if (not isSoundEnabled) then
exit;
if (chn <> -1) and (Mix_Playing(chn) <> 0) then
@@ -423,7 +423,7 @@
procedure StopSoundChan(chn, fadems: LongInt);
begin
- if not isSoundEnabled then
+ if (not isSoundEnabled) then
exit;
if (chn <> -1) and (Mix_Playing(chn) <> 0) then
@@ -437,7 +437,7 @@
exit;
s:= UserPathPrefix + '/Data/Music/' + MusicFN;
- if not FileExists(s) then
+ if (not FileExists(s)) then
s:= PathPrefix + '/Music/' + MusicFN;
WriteToConsole(msgLoading + s + ' ');
--- a/hedgewars/uStats.pas Sun Nov 11 08:45:51 2012 -0500
+++ b/hedgewars/uStats.pas Sun Nov 11 15:14:18 2012 +0100
@@ -138,7 +138,7 @@
AddVoice(sndBoring, PreviousTeam^.voicepack);
AddCaption(Format(GetEventString(eidTurnSkipped), CurrentHedgehog^.Name), cWhiteColor, capgrpMessage);
end
- else if not PlacingHogs then
+ else if (not PlacingHogs) then
AddVoice(sndCoward, PreviousTeam^.voicepack);
end;
@@ -215,7 +215,7 @@
for t:= 0 to Pred(TeamsCount) do
with TeamsArray[t]^ do
begin
- if not ExtDriven then
+ if (not ExtDriven) then
SendStat(siTeamStats, GetTeamStatString(TeamsArray[t]));
for i:= 0 to cMaxHHIndex do
begin
--- a/hedgewars/uVariables.pas Sun Nov 11 08:45:51 2012 -0500
+++ b/hedgewars/uVariables.pas Sun Nov 11 15:14:18 2012 +0100
@@ -2728,10 +2728,13 @@
vobSDVelocity:= 15;
vobSDFallSpeed:= 250;
+{$IFNDEF PAS2C}
+ //TODO: FIXME!!
cMinScreenWidth:= min(cScreenWidth, 640);
cMinScreenHeight:= min(cScreenHeight, 480);
cOrigScreenWidth:= cScreenWidth;
cOrigScreenHeight:= cScreenHeight;
+{$ENDIF}
cNewScreenWidth := cScreenWidth;
cNewScreenHeight := cScreenHeight;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/videorec/avwrapper.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,515 @@
+/*
+ * Hedgewars, a free turn based strategy game
+ * Copyright (c) 2004-2012 Andrey Korotaev <unC0Rr@gmail.com>
+ *
+ * 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 <stdlib.h>
+#include <stdio.h>
+#include <stdint.h>
+#include <string.h>
+#include <stdarg.h>
+#include "libavformat/avformat.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;
+
+/*
+Initially I wrote code for latest ffmpeg, but on Linux (Ubuntu)
+only older version is available from repository. That's why you see here
+all of this #if LIBAVCODEC_VERSION_MAJOR < 54.
+Actually, it may be possible to remove code for newer version
+and use only code for older version.
+*/
+
+#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, ...)
+{
+ const 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)
+{
+ const char Buffer[1024];
+
+ vsnprintf(Buffer, 1024, pFmt, VaArgs);
+ AddFileLogRaw(Buffer);
+}
+
+static void Log(const char* pFmt, ...)
+{
+ const 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 >= 54
+ 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 >= 54
+ 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 >= 54
+ 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 < 54
+ // 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);
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/CMakeLists.txt Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,89 @@
+
+if(CLANG)
+ set(clang_executable ${CLANG})
+else()
+ find_program(clang_executable clang-mp clang-mp-3.2 clang-mp-3.1 clang-mp-3.0 clang)
+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})
+
+
+find_package(GLEW REQUIRED)
+
+
+configure_file(${hedgewars_SOURCE_DIR}/hedgewars/config.inc.in ${CMAKE_CURRENT_BINARY_DIR}/config.inc)
+
+
+add_custom_command(OUTPUT "${CMAKE_CURRENT_BINARY_DIR}/hwengine.c"
+ COMMAND "${EXECUTABLE_OUTPUT_PATH}/pas2c${CMAKE_EXECUTABLE_SUFFIX}"
+ ARGS -n hwengine
+ -i "${hedgewars_SOURCE_DIR}/hedgewars"
+ #-i "~/xymengxy-webport/hedgewars"
+ -o "${CMAKE_CURRENT_BINARY_DIR}"
+ -a "${CMAKE_CURRENT_BINARY_DIR}"
+ DEPENDS pas2c
+ )
+
+add_custom_target(engine_c ALL DEPENDS "${CMAKE_CURRENT_BINARY_DIR}/hwengine.c")
+
+
+add_subdirectory(rtl)
+
+include_directories("${GLEW_INCLUDE_PATH}")
+include_directories(rtl)
+
+set(engine_src uDebug.c uLandTexture.c
+ LuaPas.c uFloat.c uLocale.c
+ SDLh.c uGame.c uMisc.c
+ adler32.c uGears.c uMobile.c
+ hwengine.c uGearsHandlers.c uRandom.c
+ uAI.c uGearsHandlersRope.c uRender.c
+ uAIActions.c uGearsHedgehog.c uRenderUtils.c
+ uAIAmmoTests.c uGearsList.c uScript.c
+ uAILandMarks.c uGearsRender.c uSinTable.c
+ uAIMisc.c uGearsUtils.c uSound.c
+ uAmmos.c uIO.c uStats.c
+ uCaptions.c uInputHandler.c uStore.c
+ uChat.c uLand.c uTeams.c
+ uCollisions.c uLandGenMaze.c uTextures.c
+ uCommandHandlers.c uLandGraphics.c uTypes.c
+ uCommands.c uLandObjects.c uUtils.c
+ uConsole.c uLandOutline.c uVariables.c
+ uConsts.c uLandPainted.c uVisualGears.c
+ uCursor.c uLandTemplates.c uWorld.c
+ )
+
+set(engine_hdr uGame.h uFloat.h
+ uLocale.h SDLh.h uMisc.h
+ adler32.h uDebug.h uLandTexture.h
+ LuaPas.h uGears.h uMobile.h
+ uAI.h uGearsHandlersRope.h uRender.h
+ uAIActions.h uGearsHedgehog.h uRenderUtils.h
+ uAIAmmoTests.h uGearsList.h uScript.h
+ uGearsHandlers.h uRandom.h
+ uAILandMarks.h uGearsRender.h uSinTable.h
+ uAIMisc.h uGearsUtils.h uSound.h
+ uAmmos.h uIO.h uStats.h
+ uCaptions.h uInputHandler.h uStore.h
+ uChat.h uLand.h uTeams.h
+ uCollisions.h uLandGenMaze.h uTextures.h
+ uCommandHandlers.h uLandGraphics.h uTypes.h
+ uCommands.h uLandObjects.h uUtils.h
+ uConsole.h uLandOutline.h uVariables.h
+ uConsts.h uLandPainted.h uVisualGears.h
+ uCursor.h uLandTemplates.h uWorld.h
+ )
+
+add_executable(hwengine WIN32 ${engine_src})
+add_dependencies(hwengine engine_c fpcrtl)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/CMakeLists.txt Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,21 @@
+
+set(fpcrtl_src fileio.c
+ misc.c
+ pmath.c
+ system.c
+ sysutils.c
+)
+
+include_directories(${GLEW_INCLUDE_PATH})
+
+add_library(fpcrtl ${fpcrtl_src})
+
+if(WEBGL)
+ set_target_properties(fpcrtl PROPERTIES PREFIX "em")
+ set_target_properties(fpcrtl PROPERTIES SUFFIX ".bc")
+endif(WEBGL)
+
+
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/GL.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,8 @@
+#pragma once
+
+#ifdef __APPLE__
+#include <OpenGL/gl.h>
+#else
+#include "GL/gl.h"
+#endif
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fileio.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,226 @@
+/*
+ * XXX: assume all files are text files
+ */
+
+#include "misc.h"
+#include "fileio.h"
+#include <string.h>
+#include <stdlib.h>
+#include <assert.h>
+#include <sys/stat.h>
+
+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);
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fileio.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,78 @@
+#ifndef FILEIO_H_
+#define FILEIO_H_
+
+#include <stdio.h>
+#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_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/fpcrtl.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,189 @@
+#ifndef _FPCRTL_H_
+#define _FPCRTL_H_
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <string.h>
+#include <unistd.h>
+
+#include "system.h"
+#include "misc.h"
+#include "sysutils.h"
+#include "fileio.h"
+#include "pmath.h"
+
+#ifndef EMSCRIPTEN
+#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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/misc.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,168 @@
+#include "misc.h"
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+
+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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/misc.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,58 @@
+#ifndef _FPCRTL_MISC_H_
+#define _FPCRTL_MISC_H_
+
+#include "pas2c.h"
+#include <assert.h>
+#include <stdbool.h>
+
+#ifdef EMSCRIPTEN
+#include <GL/gl.h>
+#else
+#include <GL/glew.h>
+#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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pas2c.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,80 @@
+#pragma once
+
+#include <stddef.h>
+#include <stdint.h>
+#include <stdbool.h>
+#include <wchar.h>
+#include <math.h>
+
+#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}
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pmath.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,50 @@
+#include "pmath.h"
+#include <math.h>
+#include <stdlib.h>
+#include <stdint.h>
+
+/*
+ * 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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/pmath.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,23 @@
+#ifndef PMATH_H_
+#define PMATH_H_
+
+#include <stdint.h>
+
+#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_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/system.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,275 @@
+#include "system.h"
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <wchar.h>
+#include <math.h>
+
+int paramCount;
+string255 params[MAX_PARAMS];
+
+double pi = M_PI;
+
+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);
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/system.h Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,170 @@
+#ifndef SYSTEM_H_
+#define SYSTEM_H_
+
+#include <time.h>
+#include <math.h>
+#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_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/sysutils.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,176 @@
+#include "sysutils.h"
+#include "system.h"
+#include "misc.h"
+#include <time.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/sysutils.h Sun Nov 11 15:14:18 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_check.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,23 @@
+#include <check.h>
+#include <stdlib.h>
+#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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_check.h Sun Nov 11 15:14:18 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_fileio.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,103 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_misc.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,88 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_system.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,251 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#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;
+}
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/check_sysutils.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,80 @@
+#include <check.h>
+#include <stdlib.h>
+#include <stdio.h>
+#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;
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/fileio_test.c Sun Nov 11 15:14:18 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();
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/tests/main.c Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,84 @@
+
+//#include <stdio.h>
+//#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);
+// }
+
+}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/project_files/hwc/rtl/types.h Sun Nov 11 15:14:18 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
--- a/tools/PascalBasics.hs Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module PascalBasics where
-
-import Text.Parsec.Combinator
-import Text.Parsec.Char
-import Text.Parsec.Prim
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Data.Char
-
-builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
-
-pascalLanguageDef
- = emptyDef
- { commentStart = "(*"
- , commentEnd = "*)"
- , commentLine = "//"
- , nestedComments = False
- , identStart = letter <|> oneOf "_"
- , identLetter = alphaNum <|> oneOf "_"
- , reservedNames = [
- "begin", "end", "program", "unit", "interface"
- , "implementation", "and", "or", "xor", "shl"
- , "shr", "while", "do", "repeat", "until", "case", "of"
- , "type", "var", "const", "out", "array", "packed"
- , "procedure", "function", "with", "for", "to"
- , "downto", "div", "mod", "record", "set", "nil"
- , "cdecl", "external", "if", "then", "else"
- ] -- ++ builtin
- , reservedOpNames= []
- , caseSensitive = False
- }
-
-preprocessorSwitch :: Stream s m Char => ParsecT s u m String
-preprocessorSwitch = do
- try $ string "{$"
- s <- manyTill (noneOf "\n") $ char '}'
- return s
-
-caseInsensitiveString s = do
- mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
- return s
-
-pas = patch $ makeTokenParser pascalLanguageDef
- where
- patch tp = tp {stringLiteral = stringL}
-
-comment = choice [
- char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
- , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
- , (try $ string "//") >> manyTill anyChar (try newline)
- ]
-
-comments = do
- spaces
- skipMany $ do
- preprocessorSwitch <|> comment
- spaces
-
-stringL = do
- (char '\'')
- s <- (many $ noneOf "'")
- (char '\'')
- ss <- many $ do
- (char '\'')
- s' <- (many $ noneOf "'")
- (char '\'')
- return $ '\'' : s'
- comments
- return $ concat (s:ss)
--- a/tools/PascalParser.hs Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,659 +0,0 @@
-module PascalParser where
-
-import Text.Parsec
-import Text.Parsec.Char
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Text.Parsec.Expr
-import Text.Parsec.Prim
-import Text.Parsec.Combinator
-import Text.Parsec.String
-import Control.Monad
-import Data.Maybe
-import Data.Char
-
-import PascalBasics
-import PascalUnitSyntaxTree
-
-knownTypes = ["shortstring", "ansistring", "char", "byte"]
-
-pascalUnit = do
- comments
- u <- choice [program, unit, systemUnit, redoUnit]
- comments
- return u
-
-iD = do
- i <- liftM (flip Identifier BTUnknown) (identifier pas)
- comments
- return i
-
-unit = do
- string "unit" >> comments
- name <- iD
- semi pas
- comments
- int <- interface
- impl <- implementation
- comments
- return $ Unit name int impl Nothing Nothing
-
-
-reference = buildExpressionParser table term <?> "reference"
- where
- term = comments >> choice [
- parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
- , try $ typeCast >>= postfixes
- , char '@' >> liftM Address reference >>= postfixes
- , liftM SimpleReference iD >>= postfixes
- ] <?> "simple reference"
-
- table = [
- ]
-
- postfixes r = many postfix >>= return . foldl (flip ($)) r
- postfix = choice [
- parens pas (option [] parameters) >>= return . FunCall
- , char '^' >> return Dereference
- , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
- , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
- ]
-
- typeCast = do
- t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
- e <- parens pas expression
- comments
- return $ TypeCast (Identifier t BTUnknown) e
-
-varsDecl1 = varsParser sepEndBy1
-varsDecl = varsParser sepEndBy
-varsParser m endsWithSemi = do
- vs <- m (aVarDecl endsWithSemi) (semi pas)
- return vs
-
-aVarDecl endsWithSemi = do
- isVar <- liftM (== Just "var") $
- if not endsWithSemi then
- optionMaybe $ choice [
- try $ string "var"
- , try $ string "const"
- , try $ string "out"
- ]
- else
- return Nothing
- comments
- ids <- do
- i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
- char ':'
- return i
- comments
- t <- typeDecl <?> "variable type declaration"
- comments
- init <- option Nothing $ do
- char '='
- comments
- e <- initExpression
- comments
- return (Just e)
- return $ VarDeclaration isVar False (ids, t) init
-
-
-constsDecl = do
- vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
- comments
- return vs
- where
- aConstDecl = do
- comments
- i <- iD
- t <- optionMaybe $ do
- char ':'
- comments
- t <- typeDecl
- comments
- return t
- char '='
- comments
- e <- initExpression
- comments
- return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
-
-typeDecl = choice [
- char '^' >> typeDecl >>= return . PointerTo
- , try (string "shortstring") >> return (String 255)
- , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
- , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
- , arrayDecl
- , recordDecl
- , setDecl
- , functionType
- , sequenceDecl >>= return . Sequence
- , try iD >>= return . SimpleType
- , rangeDecl >>= return . RangeType
- ] <?> "type declaration"
- where
- arrayDecl = do
- try $ do
- optional $ (try $ string "packed") >> comments
- string "array"
- comments
- r <- option [] $ do
- char '['
- r <- commaSep pas rangeDecl
- char ']'
- comments
- return r
- string "of"
- comments
- t <- typeDecl
- if null r then
- return $ ArrayDecl Nothing t
- else
- return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
- recordDecl = do
- try $ do
- optional $ (try $ string "packed") >> comments
- string "record"
- comments
- vs <- varsDecl True
- union <- optionMaybe $ do
- string "case"
- comments
- iD
- comments
- string "of"
- comments
- many unionCase
- string "end"
- return $ RecordType vs union
- setDecl = do
- try $ string "set" >> space
- comments
- string "of"
- comments
- liftM Set typeDecl
- unionCase = do
- try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
- char ':'
- comments
- u <- parens pas $ varsDecl True
- char ';'
- comments
- return u
- sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
- functionType = do
- fp <- try (string "function") <|> try (string "procedure")
- comments
- vs <- option [] $ parens pas $ varsDecl False
- comments
- ret <- if (fp == "function") then do
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- else
- return VoidType
- optional $ try $ char ';' >> comments >> string "cdecl"
- comments
- return $ FunctionType ret vs
-
-typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
- where
- aTypeDecl = do
- i <- try $ do
- i <- iD <?> "type declaration"
- comments
- char '='
- return i
- comments
- t <- typeDecl
- comments
- semi pas
- comments
- return $ TypeDeclaration i t
-
-rangeDecl = choice [
- try $ rangeft
- , iD >>= return . Range
- ] <?> "range declaration"
- where
- rangeft = do
- e1 <- initExpression
- string ".."
- e2 <- initExpression
- return $ RangeFromTo e1 e2
-
-typeVarDeclaration isImpl = (liftM concat . many . choice) [
- varSection,
- constSection,
- typeSection,
- funcDecl,
- operatorDecl
- ]
- where
- varSection = do
- try $ string "var"
- comments
- v <- varsDecl1 True <?> "variable declaration"
- comments
- return v
-
- constSection = do
- try $ string "const"
- comments
- c <- constsDecl <?> "const declaration"
- comments
- return c
-
- typeSection = do
- try $ string "type"
- comments
- t <- typesDecl <?> "type declaration"
- comments
- return t
-
- operatorDecl = do
- try $ string "operator"
- comments
- i <- manyTill anyChar space
- comments
- vs <- parens pas $ varsDecl False
- comments
- rid <- iD
- comments
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- char ';'
- comments
- forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
- inline <- liftM (any (== "inline;")) $ many functionDecorator
- b <- if isImpl && (not forward) then
- liftM Just functionBody
- else
- return Nothing
- return $ [OperatorDeclaration i rid inline ret vs b]
-
-
- funcDecl = do
- fp <- try (string "function") <|> try (string "procedure")
- comments
- i <- iD
- vs <- option [] $ parens pas $ varsDecl False
- comments
- ret <- if (fp == "function") then do
- char ':'
- comments
- ret <- typeDecl
- comments
- return ret
- else
- return VoidType
- char ';'
- comments
- forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
- inline <- liftM (any (== "inline;")) $ many functionDecorator
- b <- if isImpl && (not forward) then
- liftM Just functionBody
- else
- return Nothing
- return $ [FunctionDeclaration i inline ret vs b]
-
- functionDecorator = do
- d <- choice [
- try $ string "inline;"
- , try $ caseInsensitiveString "cdecl;"
- , try $ string "overload;"
- , try $ string "export;"
- , try $ string "varargs;"
- , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
- ]
- comments
- return d
-
-
-program = do
- string "program"
- comments
- name <- iD
- (char ';')
- comments
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration True
- comments
- p <- phrase
- comments
- char '.'
- comments
- return $ Program name (Implementation u (TypesAndVars tv)) p
-
-interface = do
- string "interface"
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration False
- comments
- return $ Interface u (TypesAndVars tv)
-
-implementation = do
- string "implementation"
- comments
- u <- uses
- comments
- tv <- typeVarDeclaration True
- string "end."
- comments
- return $ Implementation u (TypesAndVars tv)
-
-expression = do
- buildExpressionParser table term <?> "expression"
- where
- term = comments >> choice [
- builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
- , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
- , brackets pas (commaSep pas iD) >>= return . SetExpression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
- , float pas >>= return . FloatLiteral . show
- , try $ integer pas >>= return . NumberLiteral . show
- , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
- , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
- , stringLiteral pas >>= return . strOrChar
- , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
- , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
- , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h)
- --, char '-' >> expression >>= return . PrefixOp "-"
- , char '-' >> reference >>= return . PrefixOp "-" . Reference
- , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
- , try $ string "nil" >> return Null
- , reference >>= return . Reference
- ] <?> "simple expression"
-
- table = [
- [ Prefix (try (string "not") >> return (PrefixOp "not"))
- , Prefix (try (char '-') >> return (PrefixOp "-"))]
- ,
- [ Infix (char '*' >> return (BinOp "*")) AssocLeft
- , Infix (char '/' >> return (BinOp "/")) AssocLeft
- , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
- , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
- , Infix (try (string "in") >> return (BinOp "in")) AssocNone
- , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
- , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
- , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
- ]
- , [ Infix (char '+' >> return (BinOp "+")) AssocLeft
- , Infix (char '-' >> return (BinOp "-")) AssocLeft
- , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
- ]
- , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
- , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
- , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
- , Infix (char '<' >> return (BinOp "<")) AssocNone
- , Infix (char '>' >> return (BinOp ">")) AssocNone
- ]
- {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
- ]
- , [
- Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
- ]-}
- , [
- Infix (char '=' >> return (BinOp "=")) AssocNone
- ]
- ]
- strOrChar [a] = CharCode . show . ord $ a
- strOrChar a = StringLiteral a
-
-phrasesBlock = do
- try $ string "begin"
- comments
- p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
- comments
- return $ Phrases p
-
-phrase = do
- o <- choice [
- phrasesBlock
- , ifBlock
- , whileCycle
- , repeatCycle
- , switchCase
- , withBlock
- , forCycle
- , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
- , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
- , procCall
- , char ';' >> comments >> return NOP
- ]
- optional $ char ';'
- comments
- return o
-
-ifBlock = do
- try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
- comments
- e <- expression
- comments
- string "then"
- comments
- o1 <- phrase
- comments
- o2 <- optionMaybe $ do
- try $ string "else" >> space
- comments
- o <- option NOP phrase
- comments
- return o
- return $ IfThenElse e o1 o2
-
-whileCycle = do
- try $ string "while"
- comments
- e <- expression
- comments
- string "do"
- comments
- o <- phrase
- return $ WhileCycle e o
-
-withBlock = do
- try $ string "with" >> space
- comments
- rs <- (commaSep1 pas) reference
- comments
- string "do"
- comments
- o <- phrase
- return $ foldr WithBlock o rs
-
-repeatCycle = do
- try $ string "repeat" >> space
- comments
- o <- many phrase
- string "until"
- comments
- e <- expression
- comments
- return $ RepeatCycle e o
-
-forCycle = do
- try $ string "for" >> space
- comments
- i <- iD
- comments
- string ":="
- comments
- e1 <- expression
- comments
- up <- liftM (== Just "to") $
- optionMaybe $ choice [
- try $ string "to"
- , try $ string "downto"
- ]
- --choice [string "to", string "downto"]
- comments
- e2 <- expression
- comments
- string "do"
- comments
- p <- phrase
- comments
- return $ ForCycle i e1 e2 p up
-
-switchCase = do
- try $ string "case"
- comments
- e <- expression
- comments
- string "of"
- comments
- cs <- many1 aCase
- o2 <- optionMaybe $ do
- try $ string "else" >> notFollowedBy alphaNum
- comments
- o <- many phrase
- comments
- return o
- string "end"
- comments
- return $ SwitchCase e cs o2
- where
- aCase = do
- e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
- comments
- char ':'
- comments
- p <- phrase
- comments
- return (e, p)
-
-procCall = do
- r <- reference
- p <- option [] $ (parens pas) parameters
- return $ ProcCall r p
-
-parameters = (commaSep pas) expression <?> "parameters"
-
-functionBody = do
- tv <- typeVarDeclaration True
- comments
- p <- phrasesBlock
- char ';'
- comments
- return (TypesAndVars tv, p)
-
-uses = liftM Uses (option [] u)
- where
- u = do
- string "uses"
- comments
- u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
- char ';'
- comments
- return u
-
-initExpression = buildExpressionParser table term <?> "initialization expression"
- where
- term = comments >> choice [
- liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
- , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
- , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia)
- , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
- , parens pas initExpression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
- , try $ float pas >>= return . InitFloat . show
- , try $ integer pas >>= return . InitNumber . show
- , stringLiteral pas >>= return . InitString
- , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
- , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
- , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
- , try $ string "nil" >> return InitNull
- , itypeCast
- , iD >>= return . InitReference
- ]
-
- recField = do
- i <- iD
- spaces
- char ':'
- spaces
- e <- initExpression
- spaces
- return (i ,e)
-
- table = [
- [
- Prefix (char '-' >> return (InitPrefixOp "-"))
- ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
- ]
- , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft
- , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
- , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
- , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
- , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
- , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
- ]
- , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft
- , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
- , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
- ]
- , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
- , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
- , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
- , Infix (char '<' >> return (InitBinOp "<")) AssocNone
- , Infix (char '>' >> return (InitBinOp ">")) AssocNone
- , Infix (char '=' >> return (InitBinOp "=")) AssocNone
- ]
- {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
- , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
- , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
- ]
- , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
- ]--}
- --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
- ]
-
- itypeCast = do
- t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
- i <- parens pas initExpression
- comments
- return $ InitTypeCast (Identifier t BTUnknown) i
-
-builtInFunction e = do
- name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
- spaces
- exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
- spaces
- return (name, exprs)
-
-systemUnit = do
- string "system;"
- comments
- string "type"
- comments
- t <- typesDecl
- string "var"
- v <- varsDecl True
- return $ System (t ++ v)
-
-redoUnit = do
- string "redo;"
- comments
- string "type"
- comments
- t <- typesDecl
- string "var"
- v <- varsDecl True
- return $ Redo (t ++ v)
-
--- a/tools/PascalPreprocessor.hs Sun Nov 11 08:45:51 2012 -0500
+++ /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 ++ "}"
--- a/tools/PascalUnitSyntaxTree.hs Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,119 +0,0 @@
-module PascalUnitSyntaxTree where
-
-import Data.Maybe
-import Data.Char
-
-data PascalUnit =
- Program Identifier Implementation Phrase
- | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
- | System [TypeVarDeclaration]
- | Redo [TypeVarDeclaration]
- deriving Show
-data Interface = Interface Uses TypesAndVars
- deriving Show
-data Implementation = Implementation Uses TypesAndVars
- deriving Show
-data Identifier = Identifier String BaseType
- deriving Show
-data TypesAndVars = TypesAndVars [TypeVarDeclaration]
- deriving Show
-data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
- | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
- | FunctionDeclaration Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
- | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
- deriving Show
-data TypeDecl = SimpleType Identifier
- | RangeType Range
- | Sequence [Identifier]
- | ArrayDecl (Maybe Range) TypeDecl
- | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
- | PointerTo TypeDecl
- | String Integer
- | Set TypeDecl
- | FunctionType TypeDecl [TypeVarDeclaration]
- | DeriveType InitExpression
- | VoidType
- | VarParamType TypeDecl -- this is a hack
- deriving Show
-data Range = Range Identifier
- | RangeFromTo InitExpression InitExpression
- | RangeInfinite
- deriving Show
-data Initialize = Initialize String
- deriving Show
-data Finalize = Finalize String
- deriving Show
-data Uses = Uses [Identifier]
- deriving Show
-data Phrase = ProcCall Reference [Expression]
- | IfThenElse Expression Phrase (Maybe Phrase)
- | WhileCycle Expression Phrase
- | RepeatCycle Expression [Phrase]
- | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
- | WithBlock Reference Phrase
- | Phrases [Phrase]
- | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
- | Assignment Reference Expression
- | BuiltInFunctionCall [Expression] Reference
- | NOP
- deriving Show
-data Expression = Expression String
- | BuiltInFunCall [Expression] Reference
- | PrefixOp String Expression
- | PostfixOp String Expression
- | BinOp String Expression Expression
- | StringLiteral String
- | PCharLiteral String
- | CharCode String
- | HexCharCode String
- | NumberLiteral String
- | FloatLiteral String
- | HexNumber String
- | Reference Reference
- | SetExpression [Identifier]
- | Null
- deriving Show
-data Reference = ArrayElement [Expression] Reference
- | FunCall [Expression] Reference
- | TypeCast Identifier Expression
- | SimpleReference Identifier
- | Dereference Reference
- | RecordField Reference Reference
- | Address Reference
- | RefExpression Expression
- deriving Show
-data InitExpression = InitBinOp String InitExpression InitExpression
- | InitPrefixOp String InitExpression
- | InitReference Identifier
- | InitArray [InitExpression]
- | InitRecord [(Identifier, InitExpression)]
- | InitFloat String
- | InitNumber String
- | InitHexNumber String
- | InitString String
- | InitChar String
- | BuiltInFunction String [InitExpression]
- | InitSet [InitExpression]
- | InitAddress InitExpression
- | InitNull
- | InitRange Range
- | InitTypeCast Identifier InitExpression
- deriving Show
-
-data BaseType = BTUnknown
- | BTChar
- | BTString
- | BTInt
- | BTBool
- | BTFloat
- | BTRecord String [(String, BaseType)]
- | BTArray Range BaseType BaseType
- | BTFunction Bool Int BaseType
- | BTPointerTo BaseType
- | BTUnresolved String
- | BTSet BaseType
- | BTEnum [String]
- | BTVoid
- | BTUnit
- | BTVarParam BaseType
- deriving Show
--- a/tools/pas2c.hs Sun Nov 11 08:45:51 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1086 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Pas2C where
-
-import Text.PrettyPrint.HughesPJ
-import Data.Maybe
-import Data.Char
-import Text.Parsec.Prim hiding (State)
-import Control.Monad.State
-import System.IO
-import System.Directory
-import Control.Monad.IO.Class
-import PascalPreprocessor
-import Control.Exception
-import System.IO.Error
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.List (find)
-import Numeric
-
-import PascalParser(pascalUnit)
-import PascalUnitSyntaxTree
-
-
-data InsertOption =
- IOInsert
- | IOInsertWithType Doc
- | IOLookup
- | IOLookupLast
- | IOLookupFunction Int
- | IODeferred
-
-data Record = Record
- {
- lcaseId :: String,
- baseType :: BaseType,
- typeDecl :: Doc
- }
- deriving Show
-type Records = Map.Map String [Record]
-data RenderState = RenderState
- {
- currentScope :: Records,
- lastIdentifier :: String,
- lastType :: BaseType,
- lastIdTypeDecl :: Doc,
- stringConsts :: [(String, String)],
- uniqCounter :: Int,
- toMangle :: Set.Set String,
- currentUnit :: String,
- currentFunctionResult :: String,
- namespaces :: Map.Map String Records
- }
-
-rec2Records = map (\(a, b) -> Record a b empty)
-
-emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""
-
-getUniq :: State RenderState Int
-getUniq = do
- i <- gets uniqCounter
- modify(\s -> s{uniqCounter = uniqCounter s + 1})
- return i
-
-addStringConst :: String -> State RenderState Doc
-addStringConst str = do
- strs <- gets stringConsts
- let a = find ((==) str . snd) strs
- if isJust a then
- do
- modify (\s -> s{lastType = BTString})
- return . text . fst . fromJust $ a
- else
- do
- i <- getUniq
- let sn = "__str" ++ show i
- modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
- return $ text sn
-
-escapeStr :: String -> String
-escapeStr = foldr escapeChar []
-
-escapeChar :: Char -> ShowS
-escapeChar '"' s = "\\\"" ++ s
-escapeChar '\\' s = "\\\\" ++ s
-escapeChar a s = a : s
-
-strInit :: String -> Doc
-strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
-
-renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
- $ gets stringConsts
-
-docToLower :: Doc -> Doc
-docToLower = text . map toLower . render
-
-pas2C :: String -> IO ()
-pas2C fn = do
- setCurrentDirectory "../hedgewars/"
- s <- flip execStateT initState $ f fn
- renderCFiles s
- where
- printLn = liftIO . hPutStrLn stdout
- print = liftIO . hPutStr stdout
- initState = Map.empty
- f :: String -> StateT (Map.Map String PascalUnit) IO ()
- f fileName = do
- processed <- gets $ Map.member fileName
- unless processed $ do
- print ("Preprocessing '" ++ fileName ++ ".pas'... ")
- fc' <- liftIO
- $ tryJust (guard . isDoesNotExistError)
- $ preprocess (fileName ++ ".pas")
- case fc' of
- (Left a) -> do
- modify (Map.insert fileName (System []))
- printLn "doesn't exist"
- (Right fc) -> do
- print "ok, parsing... "
- let ptree = parse pascalUnit fileName fc
- case ptree of
- (Left a) -> do
- liftIO $ writeFile "preprocess.out" fc
- printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
- fail "stop"
- (Right a) -> do
- printLn "ok"
- modify (Map.insert fileName a)
- mapM_ f (usesFiles a)
-
-
-renderCFiles :: Map.Map String PascalUnit -> IO ()
-renderCFiles units = do
- let u = Map.toList units
- let nss = Map.map (toNamespace nss) units
- --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
- --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
- mapM_ (toCFiles nss) u
- where
- toNamespace :: Map.Map String Records -> PascalUnit -> Records
- toNamespace nss (System tvs) =
- currentScope $ execState f (emptyState nss)
- where
- f = do
- checkDuplicateFunDecls tvs
- mapM_ (tvar2C True False True False) tvs
- toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
- currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
- where
- f = do
- checkDuplicateFunDecls tvs
- mapM_ (tvar2C True False True False) tvs
- toNamespace _ (Program {}) = Map.empty
- toNamespace nss (Unit (Identifier i _) interface _ _ _) =
- currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
-
-
-withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
-withState' f sf = do
- st <- liftM f get
- let (a, s) = runState sf st
- modify(\st -> st{
- lastType = lastType s
- , uniqCounter = uniqCounter s
- , stringConsts = stringConsts s
- })
- return a
-
-withLastIdNamespace f = do
- li <- gets lastIdentifier
- nss <- gets namespaces
- withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
-
-withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
-withRecordNamespace _ [] = error "withRecordNamespace: empty record"
-withRecordNamespace prefix recs = withState' f
- where
- f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
- records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
- un [a] b = a : b
-
-toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO ()
-toCFiles _ (_, System _) = return ()
-toCFiles _ (_, Redo _) = return ()
-toCFiles ns p@(fn, pu) = do
- hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
- toCFiles' p
- where
- toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
- toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
- let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
- (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
- writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
- writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
- initialState = emptyState ns
-
- render2C :: RenderState -> State RenderState Doc -> String
- render2C a = render . ($+$ empty) . flip evalState a
-
-
-usesFiles :: PascalUnit -> [String]
-usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
-usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
-usesFiles (System {}) = []
-usesFiles (Redo {}) = []
-
-pascal2C :: PascalUnit -> State RenderState Doc
-pascal2C (Unit _ interface implementation init fin) =
- liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
-
-pascal2C (Program _ implementation mainFunction) = do
- impl <- implementation2C implementation
- [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
- return $ impl $+$ main
-
-
--- the second bool indicates whether do normal interface translation or generate variable declarations
--- that will be inserted into implementation files
-interface2C :: Interface -> Bool -> State RenderState Doc
-interface2C (Interface uses tvars) True = do
- u <- uses2C uses
- tv <- typesAndVars2C True True True tvars
- r <- renderStringConsts
- return (u $+$ r $+$ tv)
-interface2C (Interface uses tvars) False = do
- u <- uses2C uses
- tv <- typesAndVars2C True False False tvars
- r <- renderStringConsts
- return tv
-
-implementation2C :: Implementation -> State RenderState Doc
-implementation2C (Implementation uses tvars) = do
- u <- uses2C uses
- tv <- typesAndVars2C True False True tvars
- r <- renderStringConsts
- return (u $+$ r $+$ tv)
-
-checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
-checkDuplicateFunDecls tvs =
- modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
- where
- initMap = Map.empty
- --initMap = Map.fromList [("reset", 2)]
- ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
- ins _ m = m
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
-
-typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
-typesAndVars2C b externVar includeType(TypesAndVars ts) = do
- checkDuplicateFunDecls ts
- liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
-
-setBaseType :: BaseType -> Identifier -> Identifier
-setBaseType bt (Identifier i _) = Identifier i bt
-
-uses2C :: Uses -> State RenderState Doc
-uses2C uses@(Uses unitIds) = do
-
- mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
- mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
- mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
- return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
- where
- injectNamespace (Identifier i _) = do
- getNS <- gets (flip Map.lookup . namespaces)
- modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
-
-uses2List :: Uses -> [String]
-uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
-
-
-setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
-
-id2C :: InsertOption -> Identifier -> State RenderState Doc
-id2C IOInsert i = id2C (IOInsertWithType empty) i
-id2C (IOInsertWithType d) (Identifier i t) = do
- ns <- gets currentScope
- tom <- gets (Set.member n . toMangle)
- cu <- gets currentUnit
- let (i', t') = case (t, tom) of
- (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
- (BTFunction _ _ _, _) -> (cu ++ i, t)
- (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
- _ -> (i, t)
- modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
- return $ text i'
- where
- n = map toLower i
-
-id2C IOLookup i = id2CLookup head i
-id2C IOLookupLast i = id2CLookup last i
-id2C (IOLookupFunction params) (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- lt <- gets lastType
- if isNothing v then
- error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
- else
- let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
- modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
- where
- checkParam (Record _ (BTFunction _ p _) _) = p == params
- checkParam _ = False
-id2C IODeferred (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- if (isNothing v) then
- modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
- else
- let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i t) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- lt <- gets lastType
- if isNothing v then
- error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
- else
- let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-
-id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped = id2CTyped2 Nothing
-
-id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped2 md t (Identifier i _) = do
- tb <- resolveType t
- case (t, tb) of
- (_, BTUnknown) -> do
- error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
- (SimpleType {}, BTRecord _ r) -> do
- ts <- type2C t
- id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
- (_, BTRecord _ r) -> do
- ts <- type2C t
- id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
- _ -> case md of
- Nothing -> id2C IOInsert (Identifier i tb)
- Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
-
-
-resolveType :: TypeDecl -> State RenderState BaseType
-resolveType st@(SimpleType (Identifier i _)) = do
- let i' = map toLower i
- v <- gets $ Map.lookup i' . currentScope
- if isJust v then return . baseType . head $ fromJust v else return $ f i'
- where
- f "integer" = BTInt
- f "pointer" = BTPointerTo BTVoid
- f "boolean" = BTBool
- f "float" = BTFloat
- f "char" = BTChar
- f "string" = BTString
- f _ = error $ "Unknown system type: " ++ show st
-resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
-resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
-resolveType (RecordType tv mtvs) = do
- tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
- return . BTRecord "" . concat $ tvs
- where
- f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
- f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
-resolveType (ArrayDecl (Just i) t) = do
- t' <- resolveType t
- return $ BTArray i BTInt t'
-resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
-resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
-resolveType (DeriveType (InitHexNumber _)) = return BTInt
-resolveType (DeriveType (InitNumber _)) = return BTInt
-resolveType (DeriveType (InitFloat _)) = return BTFloat
-resolveType (DeriveType (InitString _)) = return BTString
-resolveType (DeriveType (InitBinOp {})) = return BTInt
-resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
-resolveType (DeriveType (BuiltInFunction{})) = return BTInt
-resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
-resolveType (DeriveType _) = return BTUnknown
-resolveType (String _) = return BTString
-resolveType VoidType = return BTVoid
-resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
-resolveType (RangeType _) = return $ BTVoid
-resolveType (Set t) = liftM BTSet $ resolveType t
-resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
-
-
-resolve :: String -> BaseType -> State RenderState BaseType
-resolve s (BTUnresolved t) = do
- v <- gets $ Map.lookup t . currentScope
- if isJust v then
- resolve s . baseType . head . fromJust $ v
- else
- error $ "Unknown type " ++ show t ++ "\n" ++ s
-resolve _ t = return t
-
-fromPointer :: String -> BaseType -> State RenderState BaseType
-fromPointer s (BTPointerTo t) = resolve s t
-fromPointer s t = do
- error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
-
-
-functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
-
-numberOfDeclarations :: [TypeVarDeclaration] -> Int
-numberOfDeclarations = sum . map cnt
- where
- cnt (VarDeclaration _ _ (ids, _) _) = length ids
- cnt _ = 1
-
-hasPassByReference :: [TypeVarDeclaration] -> Bool
-hasPassByReference = or . map isVar
- where
- isVar (VarDeclaration v _ (_, _) _) = v
- isVar _ = error $ "hasPassByReference called not on function parameters"
-
-toIsVarList :: [TypeVarDeclaration] -> [Bool]
-toIsVarList = concatMap isVar
- where
- isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
- isVar _ = error $ "toIsVarList called not on function parameters"
-
-
-funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
-funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
- where
- abc = hcat . punctuate comma . map (char . fst) $ ps
- cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
- ps = zip ['a'..] (toIsVarList params)
-
-fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
- t <- type2C returnType
- t'<- gets lastType
- p <- withState' id $ functionParams2C params
- n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
- let decor = if inline then text "inline" else empty
- if hasVars then
- return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
- else
- return [decor <+> t empty <+> text n <> parens p]
- where
- hasVars = hasPassByReference params
-
-
-fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
- let res = docToLower $ text rv <> text "_result"
- t <- type2C returnType
- t'<- gets lastType
-
- notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
-
- n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
-
- let isVoid = case returnType of
- VoidType -> True
- _ -> False
-
- (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
- , currentFunctionResult = if isVoid then [] else render res}) $ do
- p <- functionParams2C params
- ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
- return (p, ph)
-
- let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
- let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
- let decor = if inline then text "inline" else empty
- return [
- define
- $+$
- --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
- decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
- $+$
- text "{"
- $+$
- nest 4 phrasesBlock
- $+$
- text "}"]
- where
- phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
- phrase2C' p = phrase2C p
- un [a] b = a : b
- hasVars = hasPassByReference params
-
-fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
-fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
--- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
-tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
-tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do
- t <- fun2C b name f
- if includeType then return t else return []
-tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
- i <- id2CTyped t i'
- tp <- type2C t
- return $ if includeType then [text "typedef" <+> tp i] else []
-
-tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
- t' <- liftM ((empty <+>) . ) $ type2C t
- liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
-
-tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
- t' <- liftM (((if isConst then text "static const" else if externVar
- then text "extern"
- else empty)
- <+>) . ) $ type2C t
- ie <- initExpr mInitExpr
- lt <- gets lastType
- case (isConst, lt, ids, mInitExpr) of
- (True, BTInt, [i], Just _) -> do
- i' <- id2CTyped t i
- return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
- (True, BTFloat, [i], Just e) -> do
- i' <- id2CTyped t i
- ie <- initExpr2C e
- return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
- (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
- (_, BTArray r _ _, [i], _) -> do
- i' <- id2CTyped t i
- ie' <- return $ case (r, mInitExpr, ignoreInit) of
- (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
- (_, _, _) -> ie
- result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
- case (r, ignoreInit) of
- (RangeInfinite, False) ->
- -- if the array is dynamic, add dimension info to it
- return $ [dimDecl] ++ result
- where
- arrayDimStr = show $ arrayDimension t
- arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
- dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp
-
- (_, _) -> return result
-
- _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
- where
- initExpr Nothing = return $ empty
- initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
- varDeclDecision True True varStr expStr = varStr <+> expStr
- varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
- varDeclDecision False False varStr expStr = varStr <+> expStr
- varDeclDecision True False varStr expStr = empty
- arrayDimension a = case a of
- ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
- ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
- _ -> 0
-
-tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
- r <- op2CTyped op (extractTypes params)
- fun2C f i (FunctionDeclaration r inline ret params body)
-
-
-op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
-op2CTyped op t = do
- t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
- bt <- gets lastType
- return $ Identifier (t' ++ "_op_" ++ opStr) bt
- where
- opStr = case op of
- "+" -> "add"
- "-" -> "sub"
- "*" -> "mul"
- "/" -> "div"
- "/(float)" -> "div"
- "=" -> "eq"
- "<" -> "lt"
- ">" -> "gt"
- "<>" -> "neq"
- _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
-
-extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
-extractTypes = concatMap f
- where
- f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
- f a = error $ "extractTypes: can't extract from " ++ show a
-
-initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
-initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
-initExpr2C a = initExpr2C' a
-initExpr2C' InitNull = return $ text "NULL"
-initExpr2C' (InitAddress expr) = do
- ie <- initExpr2C' expr
- lt <- gets lastType
- case lt of
- BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"
- _ -> return $ text "&" <> ie
-initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
-initExpr2C' (InitBinOp op expr1 expr2) = do
- e1 <- initExpr2C' expr1
- e2 <- initExpr2C' expr2
- return $ parens $ e1 <+> text (op2C op) <+> e2
-initExpr2C' (InitNumber s) = return $ text s
-initExpr2C' (InitFloat s) = return $ text s
-initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-initExpr2C' (InitString [a]) = return . quotes $ text [a]
-initExpr2C' (InitString s) = return $ strInit s
-initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
-initExpr2C' (InitReference i) = id2C IOLookup i
-initExpr2C' (InitRecord fields) = do
- (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
- return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
-initExpr2C' (InitArray [value]) = initExpr2C value
-initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
- id2C IOLookup i
- t <- gets lastType
- case t of
- BTEnum s -> return . int $ length s
- BTInt -> case i' of
- "byte" -> return $ int 256
- _ -> error $ "InitRange identifier: " ++ i'
- _ -> error $ "InitRange: " ++ show r
-initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
-initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
-initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
-initExpr2C' (InitSet []) = return $ text "0"
-initExpr2C' (InitSet a) = return $ text "<<set>>"
-initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
- case e of
- (Identifier "LongInt" _) -> int (-2^31)
- (Identifier "SmallInt" _) -> int (-2^15)
- _ -> error $ "BuiltInFunction 'low': " ++ show e
-initExpr2C' (BuiltInFunction "high" [e]) = do
- initExpr2C e
- t <- gets lastType
- case t of
- (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
- a -> error $ "BuiltInFunction 'high': " ++ show a
-initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
-initExpr2C' b@(BuiltInFunction _ _) = error $ show b
-initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
-
-
-range2C :: InitExpression -> State RenderState [Doc]
-range2C (InitString [a]) = return [quotes $ text [a]]
-range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
-range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
-range2C a = liftM (flip (:) []) $ initExpr2C a
-
-baseType2C :: String -> BaseType -> Doc
-baseType2C _ BTFloat = text "float"
-baseType2C _ BTBool = text "bool"
-baseType2C _ BTString = text "string255"
-baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
-
-type2C :: TypeDecl -> State RenderState (Doc -> Doc)
-type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
-type2C t = do
- r <- type2C' t
- rt <- resolveType t
- modify (\st -> st{lastType = rt})
- return r
- where
- type2C' VoidType = return (text "void" <+>)
- type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
- type2C' (PointerTo (SimpleType i)) = do
- i' <- id2C IODeferred i
- lt <- gets lastType
- case lt of
- BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
- BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
- _ -> return $ \a -> i' <+> text "*" <+> a
- type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
- type2C' (RecordType tvs union) = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
- u <- unions
- return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
- where
- f s = s{currentUnit = ""}
- unions = case union of
- Nothing -> return empty
- Just a -> do
- structs <- mapM struct2C a
- return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
- struct2C tvs = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
- return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
- type2C' (RangeType r) = return (text "int" <+>)
- type2C' (Sequence ids) = do
- is <- mapM (id2C IOInsert . setBaseType bt) ids
- return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
- where
- bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
- type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
- type2C' (ArrayDecl (Just r) t) = do
- t' <- type2C t
- lt <- gets lastType
- ft <- case lt of
- -- BTFunction {} -> type2C (PointerTo t)
- _ -> return t'
- r' <- initExpr2C (InitRange r)
- return $ \i -> ft i <> brackets r'
- type2C' (Set t) = return (text "<<set>>" <+>)
- type2C' (FunctionType returnType params) = do
- t <- type2C returnType
- p <- withState' id $ functionParams2C params
- return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
- type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
- type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
- type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
- type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
- type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
- type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
- type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
- type2C' (DeriveType r@(InitReference {})) = do
- initExpr2C r
- t <- gets lastType
- return (baseType2C (show r) t <+>)
- type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
-
-phrase2C :: Phrase -> State RenderState Doc
-phrase2C (Phrases p) = do
- ps <- mapM phrase2C p
- return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
-phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
-phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
-phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
- r <- ref2C ref
- ps <- mapM expr2C params
- return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
-phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
- e <- expr2C expr
- p1 <- (phrase2C . wrapPhrase) phrase1
- el <- elsePart
- return $
- text "if" <> parens e $+$ p1 $+$ el
- where
- elsePart | isNothing mphrase2 = return $ empty
- | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
-phrase2C (Assignment ref expr) = do
- r <- ref2C ref
- t <- gets lastType
- case (t, expr) of
- (BTFunction {}, (Reference r')) -> do
- e <- ref2C r'
- return $ r <+> text "=" <+> e <> semi
- (BTString, _) -> do
- e <- expr2C expr
- lt <- gets lastType
- case lt of
- -- assume pointer to char for simplicity
- BTPointerTo _ -> do
- e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
- return $ r <+> text "=" <+> e <> semi
- BTString -> do
- e <- expr2C expr
- return $ r <+> text "=" <+> e <> semi
- _ -> error $ "Assignment to string from " ++ show lt
- (BTArray _ _ _, _) -> do
- case expr of
- Reference er -> do
- exprRef <- ref2C er
- exprT <- gets lastType
- case exprT of
- BTArray RangeInfinite _ _ ->
- return $ text "FIXME: assign a dynamic array to an array"
- BTArray _ _ _ -> phrase2C $
- ProcCall (FunCall
- [
- Reference $ ref
- , Reference $ RefExpression expr
- , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
- ]
- (SimpleReference (Identifier "memcpy" BTUnknown))
- ) []
- _ -> return $ text "FIXME: assign a non-specific value to an array"
-
- _ -> return $ text "FIXME: dynamic array assignment 2"
- _ -> do
- e <- expr2C expr
- return $ r <+> text "=" <+> e <> semi
-phrase2C (WhileCycle expr phrase) = do
- e <- expr2C expr
- p <- phrase2C $ wrapPhrase phrase
- return $ text "while" <> parens e $$ p
-phrase2C (SwitchCase expr cases mphrase) = do
- e <- expr2C expr
- cs <- mapM case2C cases
- d <- dflt
- return $
- text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
- where
- case2C :: ([InitExpression], Phrase) -> State RenderState Doc
- case2C (e, p) = do
- ies <- mapM range2C e
- ph <- phrase2C p
- return $
- vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
- dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
- | otherwise = do
- ph <- mapM phrase2C $ fromJust mphrase
- return [text "default:" <+> nest 4 (vcat ph)]
-
-phrase2C wb@(WithBlock ref p) = do
- r <- ref2C ref
- t <- gets lastType
- case t of
- (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
- a -> do
- error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
-phrase2C (ForCycle i' e1' e2' p up) = do
- i <- id2C IOLookup i'
- iType <- gets lastIdTypeDecl
- e1 <- expr2C e1'
- e2 <- expr2C e2'
- let inc = if up then "inc" else "dec"
- let add = if up then "+ 1" else "- 1"
- let iEnd = i <> text "__end__"
- ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
- return . braces $
- i <+> text "=" <+> e1 <> semi
- $$
- iType <+> iEnd <+> text "=" <+> e2 <> semi
- $$
- text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
- text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
- where
- appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
-phrase2C (RepeatCycle e' p') = do
- e <- expr2C e'
- p <- phrase2C (Phrases p')
- return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
-phrase2C NOP = return $ text ";"
-
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
- f <- gets currentFunctionResult
- if null f then
- return $ text "return" <> semi
- else
- return $ text "return" <+> text f <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C a = error $ "phrase2C: " ++ show a
-
-wrapPhrase p@(Phrases _) = p
-wrapPhrase p = Phrases [p]
-
-expr2C :: Expression -> State RenderState Doc
-expr2C (Expression s) = return $ text s
-expr2C b@(BinOp op expr1 expr2) = do
- e1 <- expr2C expr1
- t1 <- gets lastType
- e2 <- expr2C expr2
- t2 <- gets lastType
- case (op2C op, t1, t2) of
- ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))
- ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))
- ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))
- ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))
- ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))
- ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))
- ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))
- ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
- ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
- (_, BTRecord t1 _, BTRecord t2 _) -> do
- i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
- ref2C $ FunCall [expr1, expr2] (SimpleReference i)
- (_, BTRecord t1 _, BTInt) -> do
- -- aw, "LongInt" here is hwengine-specific hack
- i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
- ref2C $ FunCall [expr1, expr2] (SimpleReference i)
- ("in", _, _) ->
- case expr2 of
- SetExpression set -> do
- ids <- mapM (id2C IOLookup) set
- modify(\s -> s{lastType = BTBool})
- return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
- _ -> error "'in' against not set expression"
- (o, _, _) | o `elem` boolOps -> do
- modify(\s -> s{lastType = BTBool})
- return $ parens e1 <+> text o <+> parens e2
- | otherwise -> do
- o' <- return $ case o of
- "/(float)" -> text "/(float)" -- pascal returns real value
- _ -> text o
- e1' <- return $ case (o, t1, t2) of
- ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
- _ -> parens e1
- e2' <- return $ case (o, t1, t2) of
- ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
- _ -> parens e2
- return $ e1' <+> o' <+> e2'
- where
- boolOps = ["==", "!=", "<", ">", "<=", ">="]
-expr2C (NumberLiteral s) = do
- modify(\s -> s{lastType = BTInt})
- return $ text s
-expr2C (FloatLiteral s) = return $ text s
-expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-{-expr2C (StringLiteral [a]) = do
- modify(\s -> s{lastType = BTChar})
- return . quotes . text $ escape a
- where
- escape '\'' = "\\\'"
- escape a = [a]-}
-expr2C (StringLiteral s) = addStringConst s
-expr2C (PCharLiteral s) = return . doubleQuotes $ text s
-expr2C (Reference ref) = ref2CF ref
-expr2C (PrefixOp op expr) = do
- e <- expr2C expr
- lt <- gets lastType
- case lt of
- BTRecord t _ -> do
- i <- op2CTyped op [SimpleType (Identifier t undefined)]
- ref2C $ FunCall [expr] (SimpleReference i)
- BTBool -> do
- o <- return $ case op of
- "not" -> text "!"
- _ -> text (op2C op)
- return $ o <> parens e
- _ -> return $ text (op2C op) <> parens e
-expr2C Null = return $ text "NULL"
-expr2C (CharCode a) = do
- modify(\s -> s{lastType = BTChar})
- return $ quotes $ text "\\x" <> text (showHex (read a) "")
-expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
-expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
-
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
- e' <- liftM (map toLower . render) $ expr2C e
- lt <- gets lastType
- case lt of
- BTEnum a -> return $ int 0
- BTInt -> case e' of
- "longint" -> return $ int (-2147483648)
- BTArray {} -> return $ int 0
- _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
- e' <- liftM (map toLower . render) $ expr2C e
- lt <- gets lastType
- case lt of
- BTEnum a -> return . int $ length a - 1
- BTInt -> case e' of
- "longint" -> return $ int (2147483647)
- BTString -> return $ int 255
- BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
- _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
- e' <- expr2C e
- lt <- gets lastType
- modify (\s -> s{lastType = BTInt})
- case lt of
- BTString -> return $ text "fpcrtl_Length" <> parens e'
- BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
- BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
- _ -> error $ "length() called on " ++ show lt
-expr2C (BuiltInFunCall params ref) = do
- r <- ref2C ref
- t <- gets lastType
- ps <- mapM expr2C params
- case t of
- BTFunction _ _ t' -> do
- modify (\s -> s{lastType = t'})
- _ -> error $ "BuiltInFunCall lastType: " ++ show t
- return $
- r <> parens (hsep . punctuate (char ',') $ ps)
-expr2C a = error $ "Don't know how to render " ++ show a
-
-ref2CF :: Reference -> State RenderState Doc
-ref2CF (SimpleReference name) = do
- i <- id2C IOLookup name
- t <- gets lastType
- case t of
- BTFunction _ _ rt -> do
- modify(\s -> s{lastType = rt})
- return $ i <> parens empty --xymeng: removed parens
- _ -> return $ i
-ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
- i <- ref2C r
- t <- gets lastType
- case t of
- BTFunction _ _ rt -> do
- modify(\s -> s{lastType = rt})
- return $ i <> parens empty
- _ -> return $ i
-ref2CF r = ref2C r
-
-ref2C :: Reference -> State RenderState Doc
--- rewrite into proper form
-ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
-ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
-ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
-ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
-ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
--- conversion routines
-ref2C ae@(ArrayElement [expr] ref) = do
- e <- expr2C expr
- r <- ref2C ref
- t <- gets lastType
- case t of
- (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
--- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
--- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
- (BTString) -> modify (\st -> st{lastType = BTChar})
- (BTPointerTo t) -> do
- t'' <- fromPointer (show t) =<< gets lastType
- case t'' of
- BTChar -> modify (\st -> st{lastType = BTChar})
- a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
- a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
- case t of
- BTString -> return $ r <> text ".s" <> brackets e
- _ -> return $ r <> brackets e
-ref2C (SimpleReference name) = id2C IOLookup name
-ref2C rf@(RecordField (Dereference ref1) ref2) = do
- r1 <- ref2C ref1
- t <- fromPointer (show ref1) =<< gets lastType
- r2 <- case t of
- BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
- BTUnit -> error "What??"
- a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
- return $
- r1 <> text "->" <> r2
-ref2C rf@(RecordField ref1 ref2) = do
- r1 <- ref2C ref1
- t <- gets lastType
- case t of
- BTRecord _ rs -> do
- r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
- return $ r1 <> text "." <> r2
- BTUnit -> withLastIdNamespace $ ref2C ref2
- a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
-ref2C d@(Dereference ref) = do
- r <- ref2C ref
- t <- fromPointer (show d) =<< gets lastType
- modify (\st -> st{lastType = t})
- return $ (parens $ text "*" <> r)
-ref2C f@(FunCall params ref) = do
- r <- fref2C ref
- t <- gets lastType
- case t of
- BTFunction _ _ t' -> do
- ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
- modify (\s -> s{lastType = t'})
- return $ r <> ps
- _ -> case (ref, params) of
- (SimpleReference i, [p]) -> ref2C $ TypeCast i p
- _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
- where
- fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
- fref2C a = ref2C a
-
-ref2C (Address ref) = do
- r <- ref2C ref
- lt <- gets lastType
- case lt of
- BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
- _ -> return $ text "&" <> parens r
-ref2C (TypeCast t'@(Identifier i _) expr) = do
- lt <- expr2C expr >> gets lastType
- case (map toLower i, lt) of
- ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
- ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
- (a, _) -> do
- e <- expr2C expr
- t <- id2C IOLookup t'
- return . parens $ parens t <> e
-ref2C (RefExpression expr) = expr2C expr
-
-
-op2C :: String -> String
-op2C "or" = "|"
-op2C "and" = "&"
-op2C "not" = "~"
-op2C "xor" = "^"
-op2C "div" = "/"
-op2C "mod" = "%"
-op2C "shl" = "<<"
-op2C "shr" = ">>"
-op2C "<>" = "!="
-op2C "=" = "=="
-op2C "/" = "/(float)"
-op2C a = a
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/CMakeLists.txt Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,29 @@
+set(pas2c_sources
+ Main.hs
+ PascalBasics.hs
+ PascalParser.hs
+ PascalPreprocessor.hs
+ PascalUnitSyntaxTree.hs
+ pas2c.hs
+ )
+
+set(pas2c_main ${hedgewars_SOURCE_DIR}/tools/pas2c/Main.hs)
+
+set(ghc_flags
+ --make ${pas2c_main}
+ -i${hedgewars_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}")
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/Main.hs Sun Nov 11 15:14:18 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"
+ ]
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/Pas2C.hs Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,1085 @@
+{-# 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 -> 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 ++ "_"}
+ writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
+ writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
+ initialState = emptyState ns
+
+ render2C :: RenderState -> State RenderState Doc -> String
+ render2C a = render . ($+$ empty) . flip evalState a
+
+
+usesFiles :: PascalUnit -> [String]
+usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
+usesFiles (System {}) = []
+usesFiles (Redo {}) = []
+
+pascal2C :: PascalUnit -> State RenderState Doc
+pascal2C (Unit _ interface implementation init fin) =
+ liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
+
+pascal2C (Program _ implementation mainFunction) = do
+ impl <- implementation2C implementation
+ [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
+ return $ impl $+$ main
+
+
+-- the second bool indicates whether do normal interface translation or generate variable declarations
+-- that will be inserted into implementation files
+interface2C :: Interface -> Bool -> State RenderState Doc
+interface2C (Interface uses tvars) True = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True True True tvars
+ r <- renderStringConsts
+ return (u $+$ r $+$ tv)
+interface2C (Interface uses tvars) False = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True False False tvars
+ r <- renderStringConsts
+ return tv
+
+implementation2C :: Implementation -> State RenderState Doc
+implementation2C (Implementation uses tvars) = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True False True tvars
+ r <- renderStringConsts
+ return (u $+$ r $+$ tv)
+
+checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
+checkDuplicateFunDecls tvs =
+ modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
+ where
+ initMap = Map.empty
+ --initMap = Map.fromList [("reset", 2)]
+ ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
+ ins _ m = m
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+
+typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
+typesAndVars2C b externVar includeType(TypesAndVars ts) = do
+ checkDuplicateFunDecls ts
+ liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
+
+setBaseType :: BaseType -> Identifier -> Identifier
+setBaseType bt (Identifier i _) = Identifier i bt
+
+uses2C :: Uses -> State RenderState Doc
+uses2C uses@(Uses unitIds) = do
+
+ mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
+ mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
+ mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
+ return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
+ where
+ injectNamespace (Identifier i _) = do
+ getNS <- gets (flip Map.lookup . namespaces)
+ modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
+
+uses2List :: Uses -> [String]
+uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+
+
+setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
+
+id2C :: InsertOption -> Identifier -> State RenderState Doc
+id2C IOInsert i = id2C (IOInsertWithType empty) i
+id2C (IOInsertWithType d) (Identifier i t) = do
+ ns <- gets currentScope
+ tom <- gets (Set.member n . toMangle)
+ cu <- gets currentUnit
+ let (i', t') = case (t, tom) of
+ (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
+ (BTFunction _ _ _, _) -> (cu ++ i, t)
+ (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
+ _ -> (i, t)
+ modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
+ return $ text i'
+ where
+ n = map toLower i
+
+id2C IOLookup i = id2CLookup head i
+id2C IOLookupLast i = id2CLookup last i
+id2C (IOLookupFunction params) (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ lt <- gets lastType
+ if isNothing v then
+ error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
+ else
+ let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
+ modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+ where
+ checkParam (Record _ (BTFunction _ p _) _) = p == params
+ checkParam _ = False
+id2C IODeferred (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ if (isNothing v) then
+ modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
+ else
+ let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
+id2CLookup f (Identifier i t) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ lt <- gets lastType
+ if isNothing v then
+ error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
+ else
+ let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+
+id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped = id2CTyped2 Nothing
+
+id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped2 md t (Identifier i _) = do
+ tb <- resolveType t
+ case (t, tb) of
+ (_, BTUnknown) -> do
+ error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
+ (SimpleType {}, BTRecord _ r) -> do
+ ts <- type2C t
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
+ (_, BTRecord _ r) -> do
+ ts <- type2C t
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
+ _ -> case md of
+ Nothing -> id2C IOInsert (Identifier i tb)
+ Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
+
+
+resolveType :: TypeDecl -> State RenderState BaseType
+resolveType st@(SimpleType (Identifier i _)) = do
+ let i' = map toLower i
+ v <- gets $ Map.lookup i' . currentScope
+ if isJust v then return . baseType . head $ fromJust v else return $ f i'
+ where
+ f "integer" = BTInt
+ f "pointer" = BTPointerTo BTVoid
+ f "boolean" = BTBool
+ f "float" = BTFloat
+ f "char" = BTChar
+ f "string" = BTString
+ f _ = error $ "Unknown system type: " ++ show st
+resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
+resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
+resolveType (RecordType tv mtvs) = do
+ tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
+ return . BTRecord "" . concat $ tvs
+ where
+ f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
+ f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+resolveType (ArrayDecl (Just i) t) = do
+ t' <- resolveType t
+ return $ BTArray i BTInt t'
+resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
+resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
+resolveType (DeriveType (InitHexNumber _)) = return BTInt
+resolveType (DeriveType (InitNumber _)) = return BTInt
+resolveType (DeriveType (InitFloat _)) = return BTFloat
+resolveType (DeriveType (InitString _)) = return BTString
+resolveType (DeriveType (InitBinOp {})) = return BTInt
+resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
+resolveType (DeriveType (BuiltInFunction{})) = return BTInt
+resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
+resolveType (DeriveType _) = return BTUnknown
+resolveType (String _) = return BTString
+resolveType VoidType = return BTVoid
+resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+resolveType (RangeType _) = return $ BTVoid
+resolveType (Set t) = liftM BTSet $ resolveType t
+resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
+
+
+resolve :: String -> BaseType -> State RenderState BaseType
+resolve s (BTUnresolved t) = do
+ v <- gets $ Map.lookup t . currentScope
+ if isJust v then
+ resolve s . baseType . head . fromJust $ v
+ else
+ error $ "Unknown type " ++ show t ++ "\n" ++ s
+resolve _ t = return t
+
+fromPointer :: String -> BaseType -> State RenderState BaseType
+fromPointer s (BTPointerTo t) = resolve s t
+fromPointer s t = do
+ error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
+
+
+functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
+
+numberOfDeclarations :: [TypeVarDeclaration] -> Int
+numberOfDeclarations = sum . map cnt
+ where
+ cnt (VarDeclaration _ _ (ids, _) _) = length ids
+ cnt _ = 1
+
+hasPassByReference :: [TypeVarDeclaration] -> Bool
+hasPassByReference = or . map isVar
+ where
+ isVar (VarDeclaration v _ (_, _) _) = v
+ isVar _ = error $ "hasPassByReference called not on function parameters"
+
+toIsVarList :: [TypeVarDeclaration] -> [Bool]
+toIsVarList = concatMap isVar
+ where
+ isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
+ isVar _ = error $ "toIsVarList called not on function parameters"
+
+
+funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
+funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
+ where
+ abc = hcat . punctuate comma . map (char . fst) $ ps
+ cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
+ ps = zip ['a'..] (toIsVarList params)
+
+fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
+fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
+ t <- type2C returnType
+ t'<- gets lastType
+ p <- withState' id $ functionParams2C params
+ n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+ let decor = if inline then text "inline" else empty
+ if hasVars then
+ return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
+ else
+ return [decor <+> t empty <+> text n <> parens p]
+ where
+ hasVars = hasPassByReference params
+
+
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
+ let res = docToLower $ text rv <> text "_result"
+ t <- type2C returnType
+ t'<- gets lastType
+
+ notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
+
+ n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+
+ let isVoid = case returnType of
+ VoidType -> True
+ _ -> False
+
+ (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
+ , currentFunctionResult = if isVoid then [] else render res}) $ do
+ p <- functionParams2C params
+ ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
+ return (p, ph)
+
+ let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
+ let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+ let decor = if inline then text "inline" else empty
+ return [
+ define
+ $+$
+ --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+ decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
+ $+$
+ text "{"
+ $+$
+ nest 4 phrasesBlock
+ $+$
+ text "}"]
+ where
+ phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
+ phrase2C' p = phrase2C p
+ un [a] b = a : b
+ hasVars = hasPassByReference params
+
+fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
+fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
+tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
+tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do
+ t <- fun2C b name f
+ if includeType then return t else return []
+tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
+ i <- id2CTyped t i'
+ tp <- type2C t
+ return $ if includeType then [text "typedef" <+> tp i] else []
+
+tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
+ t' <- liftM ((empty <+>) . ) $ type2C t
+ liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
+
+tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
+ t' <- liftM (((if isConst then text "static const" else if externVar
+ then text "extern"
+ else empty)
+ <+>) . ) $ type2C t
+ ie <- initExpr mInitExpr
+ lt <- gets lastType
+ case (isConst, lt, ids, mInitExpr) of
+ (True, BTInt, [i], Just _) -> do
+ i' <- id2CTyped t i
+ return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
+ (True, BTFloat, [i], Just e) -> do
+ i' <- id2CTyped t i
+ ie <- initExpr2C e
+ return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
+ (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
+ (_, BTArray r _ _, [i], _) -> do
+ i' <- id2CTyped t i
+ ie' <- return $ case (r, mInitExpr, ignoreInit) of
+ (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
+ (_, _, _) -> ie
+ result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
+ case (r, ignoreInit) of
+ (RangeInfinite, False) ->
+ -- if the array is dynamic, add dimension info to it
+ return $ [dimDecl] ++ result
+ where
+ arrayDimStr = show $ arrayDimension t
+ arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
+ dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp
+
+ (_, _) -> return result
+
+ _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
+ where
+ initExpr Nothing = return $ empty
+ initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
+ varDeclDecision True True varStr expStr = varStr <+> expStr
+ varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
+ varDeclDecision False False varStr expStr = varStr <+> expStr
+ varDeclDecision True False varStr expStr = empty
+ arrayDimension a = case a of
+ ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
+ ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
+ _ -> 0
+
+tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
+ r <- op2CTyped op (extractTypes params)
+ fun2C f i (FunctionDeclaration r inline ret params body)
+
+
+op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
+op2CTyped op t = do
+ t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
+ bt <- gets lastType
+ return $ Identifier (t' ++ "_op_" ++ opStr) bt
+ where
+ opStr = case op of
+ "+" -> "add"
+ "-" -> "sub"
+ "*" -> "mul"
+ "/" -> "div"
+ "/(float)" -> "div"
+ "=" -> "eq"
+ "<" -> "lt"
+ ">" -> "gt"
+ "<>" -> "neq"
+ _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
+
+extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
+extractTypes = concatMap f
+ where
+ f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
+ f a = error $ "extractTypes: can't extract from " ++ show a
+
+initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
+initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
+initExpr2C a = initExpr2C' a
+initExpr2C' InitNull = return $ text "NULL"
+initExpr2C' (InitAddress expr) = do
+ ie <- initExpr2C' expr
+ lt <- gets lastType
+ case lt of
+ BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"
+ _ -> return $ text "&" <> ie
+initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
+initExpr2C' (InitBinOp op expr1 expr2) = do
+ e1 <- initExpr2C' expr1
+ e2 <- initExpr2C' expr2
+ return $ parens $ e1 <+> text (op2C op) <+> e2
+initExpr2C' (InitNumber s) = return $ text s
+initExpr2C' (InitFloat s) = return $ text s
+initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+initExpr2C' (InitString [a]) = return . quotes $ text [a]
+initExpr2C' (InitString s) = return $ strInit s
+initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
+initExpr2C' (InitReference i) = id2C IOLookup i
+initExpr2C' (InitRecord fields) = do
+ (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
+ return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
+initExpr2C' (InitArray [value]) = initExpr2C value
+initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
+ id2C IOLookup i
+ t <- gets lastType
+ case t of
+ BTEnum s -> return . int $ length s
+ BTInt -> case i' of
+ "byte" -> return $ int 256
+ _ -> error $ "InitRange identifier: " ++ i'
+ _ -> error $ "InitRange: " ++ show r
+initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
+initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
+initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
+initExpr2C' (InitSet []) = return $ text "0"
+initExpr2C' (InitSet a) = return $ text "<<set>>"
+initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
+ case e of
+ (Identifier "LongInt" _) -> int (-2^31)
+ (Identifier "SmallInt" _) -> int (-2^15)
+ _ -> error $ "BuiltInFunction 'low': " ++ show e
+initExpr2C' (BuiltInFunction "high" [e]) = do
+ initExpr2C e
+ t <- gets lastType
+ case t of
+ (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
+ a -> error $ "BuiltInFunction 'high': " ++ show a
+initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
+initExpr2C' b@(BuiltInFunction _ _) = error $ show b
+initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
+
+
+range2C :: InitExpression -> State RenderState [Doc]
+range2C (InitString [a]) = return [quotes $ text [a]]
+range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
+range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
+range2C a = liftM (flip (:) []) $ initExpr2C a
+
+baseType2C :: String -> BaseType -> Doc
+baseType2C _ BTFloat = text "float"
+baseType2C _ BTBool = text "bool"
+baseType2C _ BTString = text "string255"
+baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
+
+type2C :: TypeDecl -> State RenderState (Doc -> Doc)
+type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
+type2C t = do
+ r <- type2C' t
+ rt <- resolveType t
+ modify (\st -> st{lastType = rt})
+ return r
+ where
+ type2C' VoidType = return (text "void" <+>)
+ type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
+ type2C' (PointerTo (SimpleType i)) = do
+ i' <- id2C IODeferred i
+ lt <- gets lastType
+ case lt of
+ BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+ BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+ _ -> return $ \a -> i' <+> text "*" <+> a
+ type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
+ type2C' (RecordType tvs union) = do
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
+ u <- unions
+ return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
+ where
+ f s = s{currentUnit = ""}
+ unions = case union of
+ Nothing -> return empty
+ Just a -> do
+ structs <- mapM struct2C a
+ return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
+ struct2C tvs = do
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
+ return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
+ type2C' (RangeType r) = return (text "int" <+>)
+ type2C' (Sequence ids) = do
+ is <- mapM (id2C IOInsert . setBaseType bt) ids
+ return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
+ where
+ bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+ type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
+ type2C' (ArrayDecl (Just r) t) = do
+ t' <- type2C t
+ lt <- gets lastType
+ ft <- case lt of
+ -- BTFunction {} -> type2C (PointerTo t)
+ _ -> return t'
+ r' <- initExpr2C (InitRange r)
+ return $ \i -> ft i <> brackets r'
+ type2C' (Set t) = return (text "<<set>>" <+>)
+ type2C' (FunctionType returnType params) = do
+ t <- type2C returnType
+ p <- withState' id $ functionParams2C params
+ return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
+ type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
+ type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
+ type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
+ type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
+ type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
+ type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
+ type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
+ type2C' (DeriveType r@(InitReference {})) = do
+ initExpr2C r
+ t <- gets lastType
+ return (baseType2C (show r) t <+>)
+ type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
+
+phrase2C :: Phrase -> State RenderState Doc
+phrase2C (Phrases p) = do
+ ps <- mapM phrase2C p
+ return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
+phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
+phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
+phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
+ r <- ref2C ref
+ ps <- mapM expr2C params
+ return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
+phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
+ e <- expr2C expr
+ p1 <- (phrase2C . wrapPhrase) phrase1
+ el <- elsePart
+ return $
+ text "if" <> parens e $+$ p1 $+$ el
+ where
+ elsePart | isNothing mphrase2 = return $ empty
+ | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
+phrase2C (Assignment ref expr) = do
+ r <- ref2C ref
+ t <- gets lastType
+ case (t, expr) of
+ (BTFunction {}, (Reference r')) -> do
+ e <- ref2C r'
+ return $ r <+> text "=" <+> e <> semi
+ (BTString, _) -> do
+ e <- expr2C expr
+ lt <- gets lastType
+ case lt of
+ -- assume pointer to char for simplicity
+ BTPointerTo _ -> do
+ e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
+ return $ r <+> text "=" <+> e <> semi
+ BTString -> do
+ e <- expr2C expr
+ return $ r <+> text "=" <+> e <> semi
+ _ -> error $ "Assignment to string from " ++ show lt
+ (BTArray _ _ _, _) -> do
+ case expr of
+ Reference er -> do
+ exprRef <- ref2C er
+ exprT <- gets lastType
+ case exprT of
+ BTArray RangeInfinite _ _ ->
+ return $ text "FIXME: assign a dynamic array to an array"
+ BTArray _ _ _ -> phrase2C $
+ ProcCall (FunCall
+ [
+ Reference $ ref
+ , Reference $ RefExpression expr
+ , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+ ]
+ (SimpleReference (Identifier "memcpy" BTUnknown))
+ ) []
+ _ -> return $ text "FIXME: assign a non-specific value to an array"
+
+ _ -> return $ text "FIXME: dynamic array assignment 2"
+ _ -> do
+ e <- expr2C expr
+ return $ r <+> text "=" <+> e <> semi
+phrase2C (WhileCycle expr phrase) = do
+ e <- expr2C expr
+ p <- phrase2C $ wrapPhrase phrase
+ return $ text "while" <> parens e $$ p
+phrase2C (SwitchCase expr cases mphrase) = do
+ e <- expr2C expr
+ cs <- mapM case2C cases
+ d <- dflt
+ return $
+ text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
+ where
+ case2C :: ([InitExpression], Phrase) -> State RenderState Doc
+ case2C (e, p) = do
+ ies <- mapM range2C e
+ ph <- phrase2C p
+ return $
+ vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
+ dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
+ | otherwise = do
+ ph <- mapM phrase2C $ fromJust mphrase
+ return [text "default:" <+> nest 4 (vcat ph)]
+
+phrase2C wb@(WithBlock ref p) = do
+ r <- ref2C ref
+ t <- gets lastType
+ case t of
+ (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
+ a -> do
+ error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
+phrase2C (ForCycle i' e1' e2' p up) = do
+ i <- id2C IOLookup i'
+ iType <- gets lastIdTypeDecl
+ e1 <- expr2C e1'
+ e2 <- expr2C e2'
+ let inc = if up then "inc" else "dec"
+ let add = if up then "+ 1" else "- 1"
+ let iEnd = i <> text "__end__"
+ ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
+ return . braces $
+ i <+> text "=" <+> e1 <> semi
+ $$
+ iType <+> iEnd <+> text "=" <+> e2 <> semi
+ $$
+ text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
+ text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
+ where
+ appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
+phrase2C (RepeatCycle e' p') = do
+ e <- expr2C e'
+ p <- phrase2C (Phrases p')
+ return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
+phrase2C NOP = return $ text ";"
+
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
+ f <- gets currentFunctionResult
+ if null f then
+ return $ text "return" <> semi
+ else
+ return $ text "return" <+> text f <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C a = error $ "phrase2C: " ++ show a
+
+wrapPhrase p@(Phrases _) = p
+wrapPhrase p = Phrases [p]
+
+expr2C :: Expression -> State RenderState Doc
+expr2C (Expression s) = return $ text s
+expr2C b@(BinOp op expr1 expr2) = do
+ e1 <- expr2C expr1
+ t1 <- gets lastType
+ e2 <- expr2C expr2
+ t2 <- gets lastType
+ case (op2C op, t1, t2) of
+ ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))
+ ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))
+ ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))
+ ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))
+ ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))
+ ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))
+ ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))
+ ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
+ ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
+ (_, BTRecord t1 _, BTRecord t2 _) -> do
+ i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
+ ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+ (_, BTRecord t1 _, BTInt) -> do
+ -- aw, "LongInt" here is hwengine-specific hack
+ i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
+ ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+ ("in", _, _) ->
+ case expr2 of
+ SetExpression set -> do
+ ids <- mapM (id2C IOLookup) set
+ modify(\s -> s{lastType = BTBool})
+ return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
+ _ -> error "'in' against not set expression"
+ (o, _, _) | o `elem` boolOps -> do
+ modify(\s -> s{lastType = BTBool})
+ return $ parens e1 <+> text o <+> parens e2
+ | otherwise -> do
+ o' <- return $ case o of
+ "/(float)" -> text "/(float)" -- pascal returns real value
+ _ -> text o
+ e1' <- return $ case (o, t1, t2) of
+ ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
+ _ -> parens e1
+ e2' <- return $ case (o, t1, t2) of
+ ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
+ _ -> parens e2
+ return $ e1' <+> o' <+> e2'
+ where
+ boolOps = ["==", "!=", "<", ">", "<=", ">="]
+expr2C (NumberLiteral s) = do
+ modify(\s -> s{lastType = BTInt})
+ return $ text s
+expr2C (FloatLiteral s) = return $ text s
+expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+{-expr2C (StringLiteral [a]) = do
+ modify(\s -> s{lastType = BTChar})
+ return . quotes . text $ escape a
+ where
+ escape '\'' = "\\\'"
+ escape a = [a]-}
+expr2C (StringLiteral s) = addStringConst s
+expr2C (PCharLiteral s) = return . doubleQuotes $ text s
+expr2C (Reference ref) = ref2CF ref
+expr2C (PrefixOp op expr) = do
+ e <- expr2C expr
+ lt <- gets lastType
+ case lt of
+ BTRecord t _ -> do
+ i <- op2CTyped op [SimpleType (Identifier t undefined)]
+ ref2C $ FunCall [expr] (SimpleReference i)
+ BTBool -> do
+ o <- return $ case op of
+ "not" -> text "!"
+ _ -> text (op2C op)
+ return $ o <> parens e
+ _ -> return $ text (op2C op) <> parens e
+expr2C Null = return $ text "NULL"
+expr2C (CharCode a) = do
+ modify(\s -> s{lastType = BTChar})
+ return $ quotes $ text "\\x" <> text (showHex (read a) "")
+expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
+expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
+
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
+ e' <- liftM (map toLower . render) $ expr2C e
+ lt <- gets lastType
+ case lt of
+ BTEnum a -> return $ int 0
+ BTInt -> case e' of
+ "longint" -> return $ int (-2147483648)
+ BTArray {} -> return $ int 0
+ _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
+ e' <- liftM (map toLower . render) $ expr2C e
+ lt <- gets lastType
+ case lt of
+ BTEnum a -> return . int $ length a - 1
+ BTInt -> case e' of
+ "longint" -> return $ int (2147483647)
+ BTString -> return $ int 255
+ BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
+ _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
+ e' <- expr2C e
+ lt <- gets lastType
+ modify (\s -> s{lastType = BTInt})
+ case lt of
+ BTString -> return $ text "fpcrtl_Length" <> parens e'
+ BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
+ BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
+ _ -> error $ "length() called on " ++ show lt
+expr2C (BuiltInFunCall params ref) = do
+ r <- ref2C ref
+ t <- gets lastType
+ ps <- mapM expr2C params
+ case t of
+ BTFunction _ _ t' -> do
+ modify (\s -> s{lastType = t'})
+ _ -> error $ "BuiltInFunCall lastType: " ++ show t
+ return $
+ r <> parens (hsep . punctuate (char ',') $ ps)
+expr2C a = error $ "Don't know how to render " ++ show a
+
+ref2CF :: Reference -> State RenderState Doc
+ref2CF (SimpleReference name) = do
+ i <- id2C IOLookup name
+ t <- gets lastType
+ case t of
+ BTFunction _ _ rt -> do
+ modify(\s -> s{lastType = rt})
+ return $ i <> parens empty --xymeng: removed parens
+ _ -> return $ i
+ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
+ i <- ref2C r
+ t <- gets lastType
+ case t of
+ BTFunction _ _ rt -> do
+ modify(\s -> s{lastType = rt})
+ return $ i <> parens empty
+ _ -> return $ i
+ref2CF r = ref2C r
+
+ref2C :: Reference -> State RenderState Doc
+-- rewrite into proper form
+ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
+ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
+ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
+ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
+ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
+-- conversion routines
+ref2C ae@(ArrayElement [expr] ref) = do
+ e <- expr2C expr
+ r <- ref2C ref
+ t <- gets lastType
+ case t of
+ (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
+-- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
+-- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
+ (BTString) -> modify (\st -> st{lastType = BTChar})
+ (BTPointerTo t) -> do
+ t'' <- fromPointer (show t) =<< gets lastType
+ case t'' of
+ BTChar -> modify (\st -> st{lastType = BTChar})
+ a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+ a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+ case t of
+ BTString -> return $ r <> text ".s" <> brackets e
+ _ -> return $ r <> brackets e
+ref2C (SimpleReference name) = id2C IOLookup name
+ref2C rf@(RecordField (Dereference ref1) ref2) = do
+ r1 <- ref2C ref1
+ t <- fromPointer (show ref1) =<< gets lastType
+ r2 <- case t of
+ BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+ BTUnit -> error "What??"
+ a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+ return $
+ r1 <> text "->" <> r2
+ref2C rf@(RecordField ref1 ref2) = do
+ r1 <- ref2C ref1
+ t <- gets lastType
+ case t of
+ BTRecord _ rs -> do
+ r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+ return $ r1 <> text "." <> r2
+ BTUnit -> withLastIdNamespace $ ref2C ref2
+ a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+ref2C d@(Dereference ref) = do
+ r <- ref2C ref
+ t <- fromPointer (show d) =<< gets lastType
+ modify (\st -> st{lastType = t})
+ return $ (parens $ text "*" <> r)
+ref2C f@(FunCall params ref) = do
+ r <- fref2C ref
+ t <- gets lastType
+ case t of
+ BTFunction _ _ t' -> do
+ ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
+ modify (\s -> s{lastType = t'})
+ return $ r <> ps
+ _ -> case (ref, params) of
+ (SimpleReference i, [p]) -> ref2C $ TypeCast i p
+ _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
+ where
+ fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
+ fref2C a = ref2C a
+
+ref2C (Address ref) = do
+ r <- ref2C ref
+ lt <- gets lastType
+ case lt of
+ BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
+ _ -> return $ text "&" <> parens r
+ref2C (TypeCast t'@(Identifier i _) expr) = do
+ lt <- expr2C expr >> gets lastType
+ case (map toLower i, lt) of
+ ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
+ ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
+ (a, _) -> do
+ e <- expr2C expr
+ t <- id2C IOLookup t'
+ return . parens $ parens t <> e
+ref2C (RefExpression expr) = expr2C expr
+
+
+op2C :: String -> String
+op2C "or" = "|"
+op2C "and" = "&"
+op2C "not" = "~"
+op2C "xor" = "^"
+op2C "div" = "/"
+op2C "mod" = "%"
+op2C "shl" = "<<"
+op2C "shr" = ">>"
+op2C "<>" = "!="
+op2C "=" = "=="
+op2C "/" = "/(float)"
+op2C a = a
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalBasics.hs Sun Nov 11 15:14:18 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 "_"
+ , 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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalParser.hs Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,659 @@
+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)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalPreprocessor.hs Sun Nov 11 15:14:18 2012 +0100
@@ -0,0 +1,135 @@
+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 -> 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 ++ "}"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs Sun Nov 11 15:14:18 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 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/unitCycles.hs Sun Nov 11 15:14:18 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
--- a/tools/unitCycles.hs Sun Nov 11 08:45:51 2012 -0500
+++ /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