From 9d162c1bfba79ed042868f22249ecb7e625f8f0c Mon Sep 17 00:00:00 2001 From: Raymond Date: Fri, 20 Aug 2010 17:21:43 +0200 Subject: [PATCH] RUTIS to the source --- Units/RUTIS/Delphi_Versions.inc | 86 + Units/RUTIS/File_Manager.pas | 204 ++ Units/RUTIS/RUTIS_Classes.pas | 2105 ++++++++++++ Units/RUTIS/RUTIS_Compiler_Delphi.pas | 4178 ++++++++++++++++++++++++ Units/RUTIS/RUTIS_Errors.pas | 50 + Units/RUTIS/RUTIS_Errors.rst | 82 + Units/RUTIS/Rutis_Defs.pas | 1482 +++++++++ Units/RUTIS/Rutis_EXT_Canvas.pas | 429 +++ Units/RUTIS/Rutis_EXT_Common.pas | 603 ++++ Units/RUTIS/Rutis_EXT_Dialogs.pas | 126 + Units/RUTIS/Rutis_EXT_Files.pas | 253 ++ Units/RUTIS/Rutis_EXT_Forms.pas | 753 +++++ Units/RUTIS/Rutis_EXT_OpenGl.pas | 1049 ++++++ Units/RUTIS/Rutis_Engine.pas | 2278 +++++++++++++ Units/RUTIS/Rutis_ExtDll_OpenGl.pas | 1028 ++++++ Units/RUTIS/Rutis_ExtMethodInfoWin.dfm | 85 + Units/RUTIS/Rutis_ExtMethodInfoWin.lfm | 28 + Units/RUTIS/Rutis_ExtMethodInfoWin.lrs | 13 + Units/RUTIS/Rutis_ExtMethodInfoWin.pas | 223 ++ Units/RUTIS/Rutis_INI_Settings.pas | 93 + Units/RUTIS/Rutis_Stack.pas | 1131 +++++++ 21 files changed, 16279 insertions(+) create mode 100644 Units/RUTIS/Delphi_Versions.inc create mode 100644 Units/RUTIS/File_Manager.pas create mode 100644 Units/RUTIS/RUTIS_Classes.pas create mode 100644 Units/RUTIS/RUTIS_Compiler_Delphi.pas create mode 100644 Units/RUTIS/RUTIS_Errors.pas create mode 100644 Units/RUTIS/RUTIS_Errors.rst create mode 100644 Units/RUTIS/Rutis_Defs.pas create mode 100644 Units/RUTIS/Rutis_EXT_Canvas.pas create mode 100644 Units/RUTIS/Rutis_EXT_Common.pas create mode 100644 Units/RUTIS/Rutis_EXT_Dialogs.pas create mode 100644 Units/RUTIS/Rutis_EXT_Files.pas create mode 100644 Units/RUTIS/Rutis_EXT_Forms.pas create mode 100644 Units/RUTIS/Rutis_EXT_OpenGl.pas create mode 100644 Units/RUTIS/Rutis_Engine.pas create mode 100644 Units/RUTIS/Rutis_ExtDll_OpenGl.pas create mode 100644 Units/RUTIS/Rutis_ExtMethodInfoWin.dfm create mode 100644 Units/RUTIS/Rutis_ExtMethodInfoWin.lfm create mode 100644 Units/RUTIS/Rutis_ExtMethodInfoWin.lrs create mode 100644 Units/RUTIS/Rutis_ExtMethodInfoWin.pas create mode 100644 Units/RUTIS/Rutis_INI_Settings.pas create mode 100644 Units/RUTIS/Rutis_Stack.pas diff --git a/Units/RUTIS/Delphi_Versions.inc b/Units/RUTIS/Delphi_Versions.inc new file mode 100644 index 0000000..44ba760 --- /dev/null +++ b/Units/RUTIS/Delphi_Versions.inc @@ -0,0 +1,86 @@ + +{$IFDEF FPC} + {$DEFINE DELPHI_2006} + {$DEFINE DELPHI_2006_UP} + {$DEFINE DELPHI_2005_UP} + {$DEFINE DELPHI_8_UP} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER180} + {$DEFINE DELPHI_2006} + {$DEFINE DELPHI_2006_UP} + {$DEFINE DELPHI_2005_UP} + {$DEFINE DELPHI_8_UP} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER170} + {$DEFINE DELPHI_2005} + {$DEFINE DELPHI_2005_UP} + {$DEFINE DELPHI_8_UP} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER160} + {$DEFINE DELPHI_8} + {$DEFINE DELPHI_8_UP} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER150} + {$DEFINE DELPHI_7} + {$DEFINE DELPHI_7_UP} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER140} + {$DEFINE DELPHI_6} + {$DEFINE DELPHI_6_UP} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER130} + {$DEFINE DELPHI_5} + {$DEFINE DELPHI_5_UP} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER120} + {$DEFINE DELPHI_4} + {$DEFINE DELPHI_4_UP} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER110} + {$DEFINE DELPHI_3} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + +{$IFDEF VER100} + {$DEFINE DELPHI_3} + {$DEFINE DELPHI_3_UP} +{$ENDIF} + diff --git a/Units/RUTIS/File_Manager.pas b/Units/RUTIS/File_Manager.pas new file mode 100644 index 0000000..4b5ca82 --- /dev/null +++ b/Units/RUTIS/File_Manager.pas @@ -0,0 +1,204 @@ +unit File_Manager; + +interface + +uses SysUtils; + +Type + TFileItem = Record + Item : Pointer; + Name : String; + FName: String; + End; + + TFileLoadFunc = Function(FileName: String; var Item: Pointer): Boolean; + TFreeDataFunc = procedure(Item: Pointer); + TObjFileLoadFunc = Function(FileName: String; var Item: Pointer): Boolean of Object; + TObjFreeDataFunc = procedure(Item: Pointer) of Object; + + TFileManager = class + constructor Create; + Destructor Destroy; override; + private + Function SearchFileInPath(Name, Path: String): String; + Function GetItem(Name: String): Pointer; + Function IsFail(Name: String): Boolean; + public + fItems : Array Of TFileItem; + Paths : Array Of String; + FileExts : Array Of String; + NotFoundFiles : Array Of String; + LoadFunc : TFileLoadFunc; + FreeFunc : TFreeDataFunc; + ObjLoadFunc : TObjFileLoadFunc; + ObjFreeFunc : TObjFreeDataFunc; + property Items[Name: string]: Pointer read GetItem; + Procedure Clear; + Procedure AddExtension(Ext: String); + Procedure AddPath(Path: String); + Function AddItem(Name: String): Boolean; + Function SearchFile(Name: String): String; + Function IndexOf(Name: String): Integer; + end; + + +Implementation + + +//============================================================================== +//==================== File Procedures ========================================= +//============================================================================== + +constructor TFileManager.Create; +begin + //AddPath(ExtractFileDir(ParamStr(0))); +end; + +Destructor TFileManager.Destroy; +begin + Clear; +end; + +Procedure TFileManager.Clear; +var i: Integer; +begin + If Assigned(FreeFunc) then + for i := 0 to high(fItems) do + FreeFunc(fItems[i].Item); + If Assigned(ObjFreeFunc) then + for i := 0 to high(fItems) do + ObjFreeFunc(fItems[i].Item); + SetLength(fItems, 0); + SetLength(NotFoundFiles, 0); +end; + +Function TFileManager.SearchFileInPath(Name, Path: String): String; +Var SR: TSearchRec; + i: Integer; +Begin + If FindFirst(Path + Name + '.*', faAnyFile, SR) = 0 Then + Begin + Repeat + If (SR.Name <> '.') And (SR.Name <> '..') And Not ((sr.Attr And faDirectory) <> 0) Then + Begin + Result := lowerCase(ExtractFileExt(SR.Name)); + For i := 0 To high(FileExts) Do + If Result = FileExts[i] Then + Begin + Result := Path + SR.Name; + exit; + End; + End; + Until FindNext(SR) <> 0; + FindClose(SR); + End; + Result := ''; +End; + +Function TFileManager.SearchFile(Name: String): String; +Var i: Integer; +Begin + For i := 0 To high(Paths) Do + Begin + If length(Paths[i]) = 0 then Continue; + If Paths[i][length(Paths[i])] <> '\' Then Paths[i] := Paths[i] + '\'; + Result := SearchFileInPath(Name, Paths[i]); + If Result <> '' Then exit; + End; +End; + +Procedure TFileManager.AddPath(Path: String); +Begin + setLength(Paths, length(Paths) + 1); + Paths[high(Paths)] := Path; +End; + +Procedure TFileManager.AddExtension(Ext: string); +begin + If Ext[1] <> '.' then + Ext := '.' + Ext; + SetLength(FileExts,Length(FileExts)+1); + FileExts[high(FileExts)] := LowerCase(Ext); +end; + +Function TFileManager.IndexOf(Name: String): Integer; +Var i: Integer; +Begin + Name := LowerCase(Name); + Result := -1; + For i := 0 To high(fItems) Do + If fItems[i].Name = Name Then + Begin + Result := i; + exit; + End; +End; + +Function TFileManager.IsFail(Name: String): Boolean; +Var i: Integer; +Begin + Result := true; + For i := 0 To length(NotFoundFiles) - 1 Do + If NotFoundFiles[i] = Name Then exit; + Result := false; +End; + +Function TFileManager.AddItem(Name: String): Boolean; +Var fn: String; +Begin + Name := LowerCase(Name); + Result := false; + If (Assigned(LoadFunc) or Assigned(ObjLoadFunc)) and not + (Assigned(FreeFunc) or Assigned(ObjFreeFunc)) then exit; + If IsFail(Name) Then exit; + fn := SearchFile(Name); + If fn = '' Then + Begin + setLength(NotFoundFiles, length(NotFoundFiles) + 1); + NotFoundFiles[high(NotFoundFiles)] := Name; + exit; + End; + setLength(fItems, length(fItems) + 1); + fItems[high(fItems)].Name := Name; + fItems[high(fItems)].FName := FN; + If Assigned(LoadFunc) then + begin + If Not LoadFunc(fn, fItems[high(fItems)].Item) Then + Begin + setLength(fItems, length(fItems)-1); + setLength(NotFoundFiles, length(NotFoundFiles) + 1); + NotFoundFiles[high(NotFoundFiles)] := Name; + exit; + End; + end + else + If Assigned(ObjLoadFunc) then + If Not ObjLoadFunc(fn, fItems[high(fItems)].Item) Then + Begin + setLength(fItems, length(fItems)-1); + setLength(NotFoundFiles, length(NotFoundFiles) + 1); + NotFoundFiles[high(NotFoundFiles)] := Name; + exit; + End; + Result := true; +End; + +Function TFileManager.GetItem(Name: String): Pointer; +Var index: Integer; +Begin + Result := nil; + If (Assigned(LoadFunc) or Assigned(ObjLoadFunc)) and not + (Assigned(FreeFunc) or Assigned(ObjFreeFunc)) then exit; + Name := LowerCase(Name); + index := IndexOf(Name); + If Index>=0 then + begin + Result := fItems[index].Item; + exit; + end; + If not AddItem(Name) Then exit; + index := high(fItems); + Result := fItems[index].Item; +End; + +End. diff --git a/Units/RUTIS/RUTIS_Classes.pas b/Units/RUTIS/RUTIS_Classes.pas new file mode 100644 index 0000000..2116247 --- /dev/null +++ b/Units/RUTIS/RUTIS_Classes.pas @@ -0,0 +1,2105 @@ +{/============================================================================== +//============================================================================== + +RUTIS-Engine (RunTimeScript-Engine) + +Rutis_Classes.pas (part of) RUTIS-Engine + +--> This unit contains the basic classes of the RUTIS-Engine + + +//============================================================================== + +Author : Björn Zeutzheim +E-Mail : bjoern@zeutzheim-boppard.de + +//============================================================================== + +License: Dieses Projekt (RUTIS-Engine) steht unter einer / + This project is licensed under the + Creative Commons 3.0 BY-NC-SA (German) License + +Diese Lizens beinhaltet / This license includes: +-> Namensnennung / Attribution +-> Keine kommerzielle Nutzung / Noncommercial +-> Weitergabe unter gleichen Bedingungen / Share Alike + +Ein ausformulierter Lizensvertrag ist über folgende Adresse erreichbar: +The Legal Code (the full license) can be read at the following adress: +> http: //creativecommons.org/licenses/by-nc-sa/3.0/de/ + +//============================================================================== +//==============================================================================} + +Unit RUTIS_Classes; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +Uses + Windows, Forms, Classes, + {$ifdef DELPHI_7_UP}Variants,{$endif} + SysUtils, + Rutis_Defs, File_Manager; + +Type + TRutisCompiler = Class; + + TRutisEngineBase = Class + Private + fCompilerLine : Integer; + Function GetCompilerError : Boolean; + Protected + fCompilerError : ERutisCompilerError; + fScriptError : Boolean; + //================================================ + Function GetStackBase : Integer; + //================================================ + Function CheckStackIndex(Address : Integer) : Boolean; + Public + ScriptData : TRutisScriptData; + StaticDeclarations : TRutisDeclArray; + //================================================ + Compiler : TRutisCompiler; + UnitFileManager : TFileManager; + ScriptCode : TStrings; + ScriptFilePath : String; + //================================================ + OnError : TErrorProcedure; + OnCodeTimer : TNotifyEvent; + OptProcessTimer : Boolean; + OptProcessTimerCount : Integer; + //================================================ + decl_BYTE : TRutisVarType; + decl_Word : TRutisVarType; + decl_Cardinal : TRutisVarType; + decl_ShortInt : TRutisVarType; + decl_SmallInt : TRutisVarType; + decl_Integer : TRutisVarType; + decl_Single : TRutisVarType; + decl_Double : TRutisVarType; + decl_Extended : TRutisVarType; + decl_Boolean : TRutisVarType; + decl_Enum : TRutisVarType; + decl_Set4 : TRutisVarType; + decl_Pointer : TRutisVarType; + decl_Method : TRutisVarType; + decl_ObjMethod : TRutisVarType; + decl_ShortString : TRutisVarType; + decl_AChar : TRutisVarType; + decl_AString : TRutisVarType; + decl_WChar : TRutisVarType; + decl_WString : TRutisVarType; + decl_PShortString : TRutisPointerType; + decl_TClass : TRutisPointerType; + decl_TObject : TRutisClassType; + //================================================ + Constructor Create(StackBlockSize: Cardinal); + Destructor Destroy; Override; + Procedure ClearAll; Virtual; + //================================================ + Procedure CompilerMessage(Msg : String; ErrorCode : TRutisErrorType = etHint); + Procedure ScriptMessage(Msg : String; ErrorType : TRutisErrorType = etHint); + Procedure AddStaticDeclaration(Decl : TRutisDecl); + Function GetStackLvlAddress(Address, Level : Integer) : Integer; + //================================================ + Procedure RegExtMethodV(AName : String; AMethod : TExtVariMethod; AParams : Array Of String; AResult : String; ADescription : String = ''); Overload; + Procedure RegExtMethod(AName : String; AMethod : TExtStackMethod; AParams : Array Of String; AResult : String; ADescription : String = ''); Overload; + //================================================ + Procedure LoadFromStream(Stream : TStream; CanReadProtected : Boolean = False); + //================================================ + Procedure LoadScriptFromStream(Stream : TStream; CanReadProtected : Boolean = False); + Procedure SaveScriptToStream(Stream : TStream; SaveProtected : Boolean = False); + Procedure CodeUnProtect(val : Integer); + Procedure CodeProtect(val : Integer); + Procedure CodeProtego(val : Integer); + //================================================ + Procedure LoadBCodeFromStream(Stream : TStream); + Procedure SaveBCodeToStream(Stream : TStream); + //================================================ + Procedure LoadFromFile(FileName : String; CanReadProtected : Boolean = False); + Procedure LoadScriptFromFile(FileName : String; CanReadProtected : Boolean = False); + Procedure SaveScriptToFile(FileName : String; SaveProtected : Boolean = False); + Procedure LoadBCodeFromFile(FileName : String); + Procedure SaveBCodeToFile(FileName : String); + //================================================ + Procedure Compile; Overload; + Procedure Compile(AScriptCode : TStrings); Overload; + Procedure Compile(FileName : String); Overload; + //================================================ + Property CompilerError : Boolean Read GetCompilerError; + Property Error : ERutisCompilerError Read fCompilerError; + End; + + TRutisCompiler = Class + Constructor Create(AOwner : TRutisEngineBase); + Private + Protected + //CurrStatementID : Cardinal; + Public + Owner : TRutisEngineBase; + ScriptData : TRutisScriptData; + ScriptCode : TStrings; + //======================== + //Options + optArrayRangeCheck : Boolean; + optArrangeFields : Boolean; + optArrangeSize : Integer; + optCanCompileUnits : Boolean; + //======================== + Procedure Compile; Virtual; + Procedure Optimize; Virtual; + End; + + //============================================================================== +Procedure StreamWriteString(s : String; Stream : TStream); +Function StreamReadString(Stream : TStream) : String; +//============================================================================== +Implementation +//============================================================================== +//============================================================================== + +Procedure StreamWriteString(s : String; Stream : TStream); +Var Len : Integer; +Begin + Len := Length(s); + Stream.Write(Len, SizeOf(Len)); + Stream.Write(PChar(s)^, Len); +End; + +Function StreamReadString(Stream : TStream) : String; +Var Len : Integer; +Begin + Stream.Read(Len, SizeOf(Len)); + If len > 20000 Then exit; + SetLength(Result, Len); + Stream.Read(PChar(Result)^, Len); +End; + +//============================================================================== +//============================================================================== +{ TRutisEngineBase } + +Constructor TRutisEngineBase.Create(StackBlockSize: Cardinal); +Var + Decl_Copy : TRutisTypeCopy; + Decl_Ptr : TRutisPointerType; + Decl_Struct : TRutisStructType; +Begin + ScriptCode := TStringList.Create; + ScriptData := TRutisScriptData.Create(StackBlockSize); + UnitFileManager := TFileManager.Create; + + {$REGION 'Default Types'} + // UNSIGNED INTEGERS + + decl_BYTE := TRutisVarType.Create; + decl_Byte.Name := 'Byte'; + decl_Byte.Size := 1; + decl_Byte.IntType := intByte; + AddStaticDeclaration(Decl_Byte); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PByte'; + Decl_Ptr.PointerType := Decl_Byte; + AddStaticDeclaration(Decl_Ptr); + + + decl_Word := TRutisVarType.Create; + decl_Word.Name := 'Word'; + decl_Word.Size := 2; + decl_Word.IntType := intWord; + AddStaticDeclaration(Decl_Word); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PWord'; + Decl_Ptr.PointerType := Decl_Word; + AddStaticDeclaration(Decl_Ptr); + + + decl_Cardinal := TRutisVarType.Create; + decl_Cardinal.Name := 'Cardinal'; + decl_Cardinal.Size := 4; + decl_Cardinal.IntType := intCardinal; + AddStaticDeclaration(decl_Cardinal); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'LongWord'; + Decl_Copy.Size := decl_Cardinal.size; + Decl_Copy.CopyType := decl_Cardinal; + AddStaticDeclaration(Decl_Copy); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PCardinal'; + Decl_Ptr.PointerType := decl_Cardinal; + AddStaticDeclaration(Decl_Ptr); + + + // SIGNED INTEGERS + + decl_ShortInt := TRutisVarType.Create; + decl_ShortInt.Name := 'ShortInt'; + decl_ShortInt.Size := 1; + decl_ShortInt.IntType := intShortInt; + AddStaticDeclaration(decl_ShortInt); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PShortInt'; + Decl_Ptr.PointerType := decl_ShortInt; + AddStaticDeclaration(Decl_Ptr); + + + decl_SmallInt := TRutisVarType.Create; + decl_SmallInt.Name := 'SmallInt'; + decl_SmallInt.Size := 2; + decl_SmallInt.IntType := intSmallInt; + AddStaticDeclaration(decl_SmallInt); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PSmallInt'; + Decl_Ptr.PointerType := decl_SmallInt; + AddStaticDeclaration(Decl_Ptr); + + + decl_Integer := TRutisVarType.Create; + decl_Integer.Name := 'Integer'; + decl_Integer.Size := 4; + decl_Integer.IntType := intInteger; + AddStaticDeclaration(decl_Integer); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'LongInt'; + Decl_Copy.Size := decl_Integer.size; + Decl_Copy.CopyType := decl_Integer; + AddStaticDeclaration(Decl_Copy); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PInteger'; + Decl_Ptr.PointerType := decl_Integer; + AddStaticDeclaration(Decl_Ptr); + + // FLOATS + + decl_Single := TRutisVarType.Create; + decl_Single.Name := 'Single'; + decl_Single.Size := 4; + decl_Single.IntType := intSingle; + AddStaticDeclaration(decl_Single); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PSingle'; + Decl_Ptr.PointerType := decl_Single; + AddStaticDeclaration(Decl_Ptr); + + + decl_Double := TRutisVarType.Create; + decl_Double.Name := 'Double'; + decl_Double.Size := 8; + decl_Double.IntType := intDouble; + AddStaticDeclaration(decl_Double); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PDouble'; + Decl_Ptr.PointerType := decl_Double; + AddStaticDeclaration(Decl_Ptr); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'Real'; + Decl_Copy.Size := decl_Double.size; + Decl_Copy.CopyType := decl_Double; + AddStaticDeclaration(Decl_Copy); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PReal'; + Decl_Ptr.PointerType := decl_Double; + AddStaticDeclaration(Decl_Ptr); + + + decl_Extended := TRutisVarType.Create; + decl_Extended.Name := 'Extended'; + decl_Extended.Size := 10; + decl_Extended.IntType := intExtended; + AddStaticDeclaration(decl_Extended); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PExtended'; + Decl_Ptr.PointerType := decl_Extended; + AddStaticDeclaration(Decl_Ptr); + + + // OTHER + + decl_Boolean := TRutisVarType.Create; + decl_Boolean.Name := 'Boolean'; + decl_Boolean.Size := 1; + decl_Boolean.IntType := intBoolean; + AddStaticDeclaration(decl_Boolean); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PExtended'; + Decl_Ptr.PointerType := decl_Extended; + AddStaticDeclaration(Decl_Ptr); + + + decl_Enum := TRutisVarType.Create; + decl_Enum.Name := '$Enum'; + decl_Enum.Size := 1; + decl_Enum.IntType := intEnum; + AddStaticDeclaration(decl_Enum); + + decl_Set4 := TRutisVarType.Create; + decl_Set4.Name := '$Set4'; + decl_Set4.Size := 4; + decl_Set4.IntType := intSet; + AddStaticDeclaration(decl_Set4); + + decl_Pointer := TRutisVarType.Create; + decl_Pointer.Name := 'Pointer'; + decl_Pointer.Size := 4; + decl_Pointer.IntType := intPointer; + AddStaticDeclaration(decl_Pointer); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PPointer'; + Decl_Ptr.PointerType := decl_Pointer; + AddStaticDeclaration(Decl_Ptr); + + + // STRINGS AND CHARS + + decl_ShortString := TRutisVarType.Create; + decl_ShortString.Name := 'ShortString'; + decl_ShortString.Size := 256; + decl_ShortString.IntType := intShortString; + AddStaticDeclaration(decl_ShortString); + + decl_PShortString := TRutisPointerType.Create; + decl_PShortString.Name := 'PShortString'; + decl_PShortString.PointerType := decl_ShortString; + AddStaticDeclaration(decl_PShortString); + + + decl_AChar := TRutisVarType.Create; + decl_AChar.Name := 'AnsiChar'; + decl_AChar.Size := 1; + decl_AChar.IntType := intAChar; + AddStaticDeclaration(decl_AChar); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'Char'; + Decl_Copy.Size := decl_AChar.size; + Decl_Copy.CopyType := decl_AChar; + AddStaticDeclaration(Decl_Copy); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PAnsiChar'; + Decl_Ptr.PointerType := decl_AChar; + AddStaticDeclaration(Decl_Ptr); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'PChar'; + Decl_Copy.Size := Decl_Ptr.size; + Decl_Copy.CopyType := Decl_Ptr; + AddStaticDeclaration(Decl_Copy); + + + decl_AString := TRutisVarType.Create; + decl_AString.Name := 'AnsiString'; + decl_AString.Size := 4; + decl_AString.IntType := intAString; + AddStaticDeclaration(decl_AString); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'String'; + Decl_Copy.Size := decl_AString.size; + Decl_Copy.CopyType := decl_AString; + AddStaticDeclaration(Decl_Copy); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PAnsiString'; + Decl_Ptr.PointerType := decl_AString; + AddStaticDeclaration(Decl_Ptr); + + Decl_Copy := TRutisTypeCopy.Create; + Decl_Copy.Name := 'PString'; + Decl_Copy.Size := Decl_Ptr.size; + Decl_Copy.CopyType := Decl_Ptr; + AddStaticDeclaration(Decl_Copy); + + + + decl_WChar := TRutisVarType.Create; + decl_WChar.Name := 'WideChar'; + decl_WChar.Size := 1; + decl_WChar.IntType := intWChar; + AddStaticDeclaration(decl_WChar); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PWideChar'; + Decl_Ptr.PointerType := decl_WChar; + AddStaticDeclaration(Decl_Ptr); + + + decl_WString := TRutisVarType.Create; + decl_WString.Name := 'WideString'; + decl_WString.Size := 4; + decl_WString.IntType := intWString; + AddStaticDeclaration(decl_WString); + + Decl_Ptr := TRutisPointerType.Create; + Decl_Ptr.Name := 'PWideString'; + Decl_Ptr.PointerType := decl_WString; + AddStaticDeclaration(Decl_Ptr); + + {$ENDREGION} + + {$REGION 'Spezial Types'} + //================================================================== + decl_Method := TRutisVarType.Create; + decl_Method.Name := 'Method'; + decl_Method.Size := 4; + decl_Method.IntType := intMethod; + AddStaticDeclaration(decl_Method); + + //================================================================== + decl_ObjMethod := TRutisVarType.Create; + decl_ObjMethod.Name := 'MethodOfObject'; + decl_ObjMethod.Size := 8; + decl_ObjMethod.IntType := intObjMethod; + AddStaticDeclaration(decl_ObjMethod); + + //================================================================== + Decl_Struct := TRutisStructType.Create; + Decl_Struct.Name := 'TClass_OBJDATA'; + AddStaticDeclaration(Decl_Struct); + + SetLength(Decl_Struct.StructTypes, 3); + Decl_Struct.StructTypes[0] := TRutisVarDecl.Create; + Decl_Struct.StructTypes[0].VarType := decl_PShortString; + Decl_Struct.StructTypes[0].Address := vmtClassName; + Decl_Struct.StructTypes[0].isConst := False; + Decl_Struct.StructTypes[0].Level := 0; + Decl_Struct.StructTypes[0].Name := 'CLASSNAME'; + + Decl_Struct.StructTypes[1] := TRutisVarDecl.Create; + Decl_Struct.StructTypes[1].VarType := decl_Cardinal; + Decl_Struct.StructTypes[1].Address := vmtInstanceSize; + Decl_Struct.StructTypes[1].isConst := False; + Decl_Struct.StructTypes[1].Level := 0; + Decl_Struct.StructTypes[1].Name := 'INSTANCESIZE'; + + Decl_Struct.StructTypes[2] := TRutisVarDecl.Create; + Decl_Struct.StructTypes[2].VarType := decl_Cardinal; + Decl_Struct.StructTypes[2].Address := vmtParent; + Decl_Struct.StructTypes[2].isConst := False; + Decl_Struct.StructTypes[2].Level := 0; + Decl_Struct.StructTypes[2].Name := 'CLASSPARENT'; + + //================================================================== + decl_TClass := TRutisPointerType.Create; + decl_TClass.Name := 'TClass'; + decl_TClass.PointerType := Decl_Struct; + AddStaticDeclaration(decl_TClass); + + //================================================================== + Decl_Struct := TRutisStructType.Create; + Decl_Struct.Name := 'TObject_CLASSDATA'; + Decl_Struct.Size := 4; + Decl_Struct.IsPacked := False; + AddStaticDeclaration(Decl_Struct); + + SetLength(Decl_Struct.StructTypes, 1); + Decl_Struct.StructTypes[0] := TRutisVarDecl.Create; + Decl_Struct.StructTypes[0].VarType := decl_TClass; + Decl_Struct.StructTypes[0].Address := 0; + Decl_Struct.StructTypes[0].isConst := False; + Decl_Struct.StructTypes[0].Level := 0; + Decl_Struct.StructTypes[0].Name := 'CLASSTYPE'; + + //================================================================== + decl_TObject := TRutisClassType.Create; + decl_TObject.Name := 'TObject'; + decl_TObject.ClassStruct := Decl_Struct; + decl_TObject.IsExternal := True; + AddStaticDeclaration(decl_TObject); + {$ENDREGION} + + {$REGION 'Test'} +(* {$REGION 'Byte ConvertTable'} + i := 0; + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_Byte.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_Byte.ConvertTable[i].ConvSeq, 1); + decl_Byte.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Byte.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Byte.IntType); + decl_Byte.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_Byte.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_Byte.ConvertTable, i+1); + decl_Byte.ConvertTable[i].ConvType := decl_AnsiChar; + decl_Byte.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'Word ConvertTable'} + i := 0; + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_Word.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_Word.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_Word.ConvertTable, i+1); + decl_Word.ConvertTable[i].ConvType := decl_AnsiChar; + SetLength(decl_Word.ConvertTable[i].ConvSeq, 1); + decl_Word.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Word.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Word.IntType); + decl_Word.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_AnsiChar.IntType); + decl_Word.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'Cardinal ConvertTable'} + i := 0; + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_Cardinal.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_Cardinal.ConvertTable[i].ConvSeq, 1); + decl_Cardinal.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_Cardinal.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_Cardinal.IntType); + decl_Cardinal.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_Cardinal.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_Cardinal.ConvertTable, i+1); + decl_Cardinal.ConvertTable[i].ConvType := decl_AnsiChar; + decl_Cardinal.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'XXXX ConvertTable'} + i := 0; + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_AnsiChar; + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'XXXX ConvertTable'} + i := 0; + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_AnsiChar; + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'XXXX ConvertTable'} + i := 0; + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_AnsiChar; + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'XXXX ConvertTable'} + i := 0; + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_AnsiChar; + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + {$REGION 'XXXX ConvertTable'} + i := 0; + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Byte; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Byte.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Word; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Word.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Cardinal; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Cardinal.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_ShortInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_ShortInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_SmallInt; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_SmallInt.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Integer; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Integer.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Single; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Single.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Double; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Double.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Extended; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Extended.IntType); + decl_XXXX.ConvertTable[i].Explicit := false; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_Boolean; + SetLength(decl_XXXX.ConvertTable[i].ConvSeq, 1); + decl_XXXX.ConvertTable[i].ConvSeq[0] := CONV_CMD; + decl_XXXX.ConvertTable[i].ConvSeq[0].P1 := Integer(decl_XXXX.IntType); + decl_XXXX.ConvertTable[i].ConvSeq[0].P2 := Integer(decl_Boolean.IntType); + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + SetLength(decl_XXXX.ConvertTable, i+1); + decl_XXXX.ConvertTable[i].ConvType := decl_AnsiChar; + decl_XXXX.ConvertTable[i].Explicit := true; + inc(i); + {$ENDREGION} + *) + {$ENDREGION} +End; + +Destructor TRutisEngineBase.Destroy; +Var i : Integer; +Begin + For i := 0 To high(StaticDeclarations) Do + StaticDeclarations[i].Free; + SetLength(StaticDeclarations, 0); + + FreeAndNil(ScriptData); + FreeAndNil(Compiler); + FreeAndNil(ScriptCode); + FreeAndNil(fCompilerError); + + Inherited; +End; + +Procedure TRutisEngineBase.ClearAll; +Begin + ScriptData.Clear; + ScriptData.Stack.Clear; +End; + +//============================================================================== + +Procedure TRutisEngineBase.ScriptMessage(Msg : String; ErrorType : TRutisErrorType = etHint); +Begin + Msg := 'Runtime Error: (' + ScriptData.ScriptName + ') ' + Msg; + fScriptError := fScriptError or (ErrorType = etRuntimeError); + + {$ifdef DEBUG}OutputDebugString(PChar(Msg));{$endif} + If Assigned(OnError) Then + OnError(Msg, ErrorType) + Else + {$ifdef WINCE} + MessageBox(0, PWideChar(Msg), 'Error!', 0); + {$else WINCE} + MessageBox(0, PChar(Msg), 'Error!', 0); + {$endif} +End; + +Procedure TRutisEngineBase.AddStaticDeclaration(Decl : TRutisDecl); +Begin + If Decl = nil Then exit; + SetLength(StaticDeclarations, length(StaticDeclarations) + 1); + StaticDeclarations[high(StaticDeclarations)] := Decl; + Decl.Name := UpperCase(Decl.Name); + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngineBase.AddStaticDeclaration - Added Declaration : ' + Decl.Name));{$endif} +End; + +//============================================================================== + +Procedure TRutisEngineBase.RegExtMethodV(AName : String; AMethod : TExtVariMethod; AParams : Array Of String; AResult : String; ADescription : String = ''); +Var + i : Integer; + Dat : TRutisExtMethodType; + MethodVar : TRutisVarDecl; + DoOverload : Boolean; +Begin + DoOverload := False; + Dat := TRutisExtMethodType(FindDeclaration(AName, @StaticDeclarations)); + If Dat <> nil Then + Begin + If Dat is TRutisExtMethodType Then + Begin + Dat.Overloaded := True; + DoOverload := True; + End + Else + exit; + End; + + Dat := TRutisExtMethodType.Create; + With Dat Do + Begin + Name := '$ExtVariantMethod'; + Description := ADescription; + Method_Name := AName; + VariMethod := AMethod; + StackMethod := nil; + ParamsSize := 0; + Overloaded := DoOverload; + MethodResult.Name := AResult; + IsFunction := AResult <> ''; + + SetLength(Params, Length(AParams)); + For i := 0 To high(AParams) Do + Begin + Params[i].Name := AParams[i]; + Params[i].isVarParam := False; + + {id := FindDeclarationID(AParams[i], @StaticDeclarations); + If (id < 0) or + (not (StaticDeclarations[id] is TRutisTypeDecl)) Then + Begin + Dat.Free; + exit; + End; + Params[i].TypeData := TRutisTypeDecl(StaticDeclarations[id]); + ParamsSize := ParamsSize + TRutisTypeDecl(StaticDeclarations[id]).Size; } + End; + { + If IsFunction Then + Begin + id := FindDeclarationID(AResult, @StaticDeclarations); + If (id < 0) or + //false then + (not (StaticDeclarations[id] is TRutisTypeDecl)) Then + Begin + Dat.Free; + exit; + End; + ResultType := TRutisTypeDecl(StaticDeclarations[id]); + End; + } + End; + + MethodVar := TRutisVarDecl.Create; + MethodVar.Name := UpperCase(AName); + MethodVar.IsConst := True; + MethodVar.Level := 0; + MethodVar.VarType := dat; + + SetLength(StaticDeclarations, length(StaticDeclarations) + 1); + StaticDeclarations[high(StaticDeclarations)] := MethodVar; + + SetLength(StaticDeclarations, length(StaticDeclarations) + 1); + StaticDeclarations[high(StaticDeclarations)] := dat; + + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.RegExtMethod - Added Ext-Variant-Method : ' + AName));{$endif} +End; + +Procedure TRutisEngineBase.RegExtMethod(AName : String; AMethod : TExtStackMethod; AParams : Array Of String; AResult : String; ADescription : String = ''); +Var + i : Integer; + Dat : TRutisExtMethodType; + MethodVar : TRutisVarDecl; + DoOverload : Boolean; +Begin + DoOverload := False; + Dat := TRutisExtMethodType(FindDeclaration(AName, @StaticDeclarations)); + If Dat <> nil Then + Begin + If Dat is TRutisExtMethodType Then + Begin + Dat.Overloaded := True; + DoOverload := True; + End + Else + exit; + End; + + Dat := TRutisExtMethodType.Create; + With Dat Do + Begin + Name := '$ExtMethod'; + Description := ADescription; + Method_Name := AName; + VariMethod := nil; + StackMethod := AMethod; + ParamsSize := 0; + Overloaded := DoOverload; + MethodResult.Name := AResult; + IsFunction := AResult <> ''; + + SetLength(Params, Length(AParams)); + For i := 0 To high(AParams) Do + Begin + Params[i].Name := AParams[i]; + Params[i].isVarParam := False; + {id := FindDeclarationID(AParams[i], @StaticDeclarations); + If (id < 0) or + (not (StaticDeclarations[id] is TRutisTypeDecl)) Then + Begin + Dat.Free; + exit; + End; + Params[i].TypeData := TRutisTypeDecl(StaticDeclarations[id]); + ParamsSize := ParamsSize + TRutisTypeDecl(StaticDeclarations[id]).Size; } + End; + + { + If IsFunction Then + Begin + id := FindDeclarationID(AResult, @StaticDeclarations); + If (id < 0) or + //false then + (not (StaticDeclarations[id] is TRutisTypeDecl)) Then + Begin + Dat.Free; + exit; + End; + ResultType := TRutisTypeDecl(StaticDeclarations[id]); + End; + } + End; + + MethodVar := TRutisVarDecl.Create; + MethodVar.Name := UpperCase(AName); + MethodVar.IsConst := True; + MethodVar.Level := 0; + MethodVar.VarType := dat; + + SetLength(StaticDeclarations, length(StaticDeclarations) + 1); + StaticDeclarations[high(StaticDeclarations)] := MethodVar; + + SetLength(StaticDeclarations, length(StaticDeclarations) + 1); + StaticDeclarations[high(StaticDeclarations)] := dat; + + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.RegExtMethod - Added Ext-Stack-Method : ' + AName));{$endif} +End; + +//============================================================================== +//============================================================================== + +Function TRutisEngineBase.GetStackBase : Integer; +Begin + Result := 0; + If length(ScriptData.CallStack) = 0 Then exit; + Result := ScriptData.CallStack[high(ScriptData.CallStack)].StackBase; +End; + +Function TRutisEngineBase.CheckStackIndex(Address : Integer) : Boolean; +Begin + Result := (Address < 0) or (Address > ScriptData.Stack.Top); + If Result Then + ScriptMessage('Address Error (Address ID = ' + IntToStr(Address) + ')'); +End; + +Function TRutisEngineBase.GetStackLvlAddress(Address, Level : Integer) : Integer; +Var + i : Integer; +Begin + If (Level <= 0) Then + If Address < 0 Then + Result := ScriptData.Stack.Top + Address + Else + Result := Address + Else + Begin + i := high(ScriptData.CallStack); + If i < 0 Then + Begin + Result := -1; + exit; + End; + While ScriptData.CallStack[i].Level > Level Do + Dec(i); + Result := ScriptData.CallStack[i].StackBase + Address; + End; +End; + +//============================================================================== + +Function TRutisEngineBase.GetCompilerError : Boolean; +Begin + Result := fCompilerError <> nil; +End; + +//============================================================================== + +Procedure TRutisEngineBase.CompilerMessage(Msg : String; ErrorCode : TRutisErrorType = etHint); +Begin + If Assigned(OnError) Then + OnError(Msg, ErrorCode) + Else + {$ifdef WINCE} + MessageBox(0, PWideChar(Msg), 'Error!', 0); + {$else WINCE} + MessageBox(0, PChar(Msg), 'Error!', 0); + {$endif} +End; + +//============================================================================== + +Procedure TRutisEngineBase.Compile; +Var + i : Integer; + Msg : String; +Begin + If Compiler = nil Then exit; + + Compiler.ScriptCode := ScriptCode; + UnitFileManager.AddPath(ScriptFilePath); + + ScriptData.Clear; + + For i := 0 To high(StaticDeclarations) Do + ScriptData.AddDeclaration(StaticDeclarations[i], '$STATIC'); + + FreeAndNil(fCompilerError); + Try + Compiler.Compile; + Except + On E : ERutisCompilerError Do + Begin + SetLength(ScriptData.Code, 0); + + fCompilerError := ERutisCompilerError.Create(''); + fCompilerError.Assign(E); + + Msg := Format('Error: %s (%d; %d): %s', [E.ENamespace, E.ELine + 1, E.EChrPos, E.Message]); + //Msg := Format('Error: %s : %s', [E.ENamespace, E.Message]); + CompilerMessage(Msg, etCompilerError); + End; + //on E: EAccessViolation do + // CompilerMessage(Format('Error: Access Violation at %p', [E.ExceptionRecord.ExceptionAddress]), etCompilerError); + Else + Begin + SetLength(ScriptData.Code, 0); + + Raise; + {fCompilerError := ERutisCompilerError.Create(''); + fCompilerError.Assign(E); + + Msg := Format('Error: %s (%d; %d): %s', [E.ENamespace, E.ELine + 1, E.EChrPos, E.Message]); + //Msg := Format('Error: %s : %s', [E.ENamespace, E.Message]); + CompilerMessage(Msg, 0);} + End; + End; + + {$ifdef DEBUG}OutputDebugString('TRutisEngineBase.Compile - Finished compiling');{$endif} + + fCompilerLine := ScriptData.CompilerLine; +End; + +Procedure TRutisEngineBase.Compile(AScriptCode : TStrings); +Begin + If Compiler = nil Then exit; + ScriptCode.Clear; + ScriptCode.AddStrings(AScriptCode); + + Compile; +End; + +Procedure TRutisEngineBase.Compile(FileName : String); +Begin + LoadFromFile(FileName); + Compile; +End; + +//============================================================================== +//============================================================================== + +Procedure TRutisEngineBase.LoadFromStream(Stream : TStream; CanReadProtected : Boolean = False); +Var + ln : String; + ProtCode : Integer; + StreamPos : Int64; +Begin + StreamPos := Stream.Position; + If StreamReadString(Stream) = 'Compiled RUTIS-Engine Script - (c) Björn Zeutzheim' Then + Begin + Stream.Position := StreamPos; + LoadBCodeFromStream(Stream); + exit; + End; + Stream.Position := StreamPos; + ScriptCode.LoadFromStream(Stream); + If ScriptCode.Count <= 0 Then exit; + + ln := ScriptCode.Strings[0]; + If ln = 'protego' Then + Begin + If not CanReadProtected Then + Begin + ScriptCode.Clear; + exit; + End; + ln := ScriptCode.Strings[1]; + ln := copy(ln, 1, pos(' ', ln) - 1); + ProtCode := StrToInt(ln); + + ScriptCode.Delete(0); + ScriptCode.Delete(0); + + CodeUnProtect(ProtCode); + End; +End; + +//============================================================================== + +Procedure TRutisEngineBase.LoadScriptFromStream(Stream : TStream; CanReadProtected : Boolean = False); +Var + ln : String; + ProtCode : Integer; +Begin + ScriptCode.LoadFromStream(Stream); + If ScriptCode.Count <= 0 Then exit; + + ln := ScriptCode.Strings[0]; + If ln = 'protego' Then + Begin + If not CanReadProtected Then + Begin + ScriptCode.Clear; + exit; + End; + ln := ScriptCode.Strings[1]; + ln := copy(ln, 1, pos(' ', ln) - 1); + ProtCode := StrToInt(ln); + + ScriptCode.Delete(0); + ScriptCode.Delete(0); + + CodeUnProtect(ProtCode); + End; +End; + +Procedure TRutisEngineBase.SaveScriptToStream(Stream : TStream; SaveProtected : Boolean = False); +Var CodeSave : TStringList; +Begin + If SaveProtected Then + Begin + CodeSave := TStringList.Create; + CodeSave.Assign(ScriptCode); + Try + CodeProtego(random(255)); + ScriptCode.SaveToStream(Stream); + Finally + ScriptCode.Assign(CodeSave); + CodeSave.Free; + End; + End + Else + ScriptCode.SaveToStream(Stream); +End; + +Procedure TRutisEngineBase.CodeProtego(val : Integer); +Var + ln, ln2 : String; + i : Integer; +Begin + ln := ScriptCode.Text; + + ln := ln + ' '; + ln2 := ''; + For I := 1 To length(ln) - 1 Do + If (not ((ln[i] = ' ') and (ln[i + 1] = ' '))) and (ln[i] <> #13) Then + ln2 := ln2 + ln[i]; + + {ln := ''; + for I := 0 to ScriptCode.Count - 1 do + ln := ln + ScriptCode[i]; } + + ScriptCode.Text := ln2; + + CodeProtect(val); + ScriptCode.Insert(0, IntToStr(val) + ' '); + ScriptCode.Insert(0, 'protego'); +End; + +Procedure TRutisEngineBase.CodeProtect(val : Integer); +Var + i : Integer; + ln : String; +Begin + ln := ScriptCode.Text; + If length(ln) > 4 Then + Begin + If (ln[length(ln) - 1] = #13) and (ln[length(ln)] = #10) Then + ln := copy(ln, 1, length(ln) - 2); + End; + For I := 1 To length(ln) Do + Begin + ln[i] := Chr(Ord(ln[i]) + val); + End; + ScriptCode.Text := ln; +End; + +Procedure TRutisEngineBase.CodeUnProtect(val : Integer); +Begin + CodeProtect(-val); +End; + +//============================================================================== + +Procedure TRutisEngineBase.LoadBCodeFromStream(Stream : TStream); +Var + i, j, k : Integer; + IsExtMethod : Boolean; + DllMethod : TRutisDllMethodType; + TempSize : Word; + TempStr : String; + IntType : TRutisIntType; +Begin + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.LoadCodeFromStream - Loading compiled Script'));{$endif} + If StreamReadString(Stream) <> 'Compiled RUTIS-Engine Script - (c) Björn Zeutzheim' Then exit; + + ScriptCode.Clear; + ClearAll; + + ScriptData.ScriptName := StreamReadString(Stream); + + //=========================================== + If StreamReadString(Stream) <> '#CODEDATA#' Then exit; + Stream.Read(i, sizeof(i)); + SetLength(ScriptData.Code, i); + For i := 0 To high(ScriptData.Code) Do + Stream.Read(ScriptData.Code[i], sizeof(TRutisScriptCmd)); + + //=========================================== + If StreamReadString(Stream) <> '#METHODINFOTABLE#' Then exit; + Stream.Read(i, sizeof(i)); + SetLength(ScriptData.MethodTable, i); + For i := 0 To high(ScriptData.MethodTable) Do + Begin + Stream.Read(IsExtMethod, sizeof(IsExtMethod)); + If IsExtMethod Then + Begin + TempStr := StreamReadString(Stream); + For j := 0 To high(StaticDeclarations) Do + If StaticDeclarations[j] is TRutisExtMethodType Then + If LowerCase(TRutisExtMethodType(StaticDeclarations[j]).Method_Name) = LowerCase(TempStr) Then + Begin + ScriptData.MethodTable[i] := TRutisExtMethodType(StaticDeclarations[j]); + With ScriptData.MethodTable[i] Do + Begin + MethodTableID := i; + ParamsSize := 0; + Stream.Read(MethodResult.Size, SizeOf(MethodResult.Size)); + Stream.Read(MethodResult.InternalType, SizeOf(MethodResult.InternalType)); + Stream.Read(k, SizeOf(k)); + SetLength(Params, k); + For k := 0 To high(Params) Do + Begin + Stream.Read(Params[k].Size, SizeOf(Params[k].Size)); + Stream.Read(Params[k].InternalType, SizeOf(Params[k].InternalType)); + ParamsSize := ParamsSize + Params[k].Size; + End; + End; + break; + End; + End + Else + Begin + DllMethod := TRutisDllMethodType.Create; + ScriptData.AddDeclaration(DllMethod, '$SYSTEM'); + ScriptData.MethodTable[i] := DllMethod; + DllMethod.MethodTableID := i; + DllMethod.DllName := StreamReadString(Stream); + DllMethod.ProcName := StreamReadString(Stream); + Stream.Read(DllMethod.ParamsSize, SizeOf(Word)); + Stream.Read(DllMethod.IsFunction, SizeOf(Boolean)); + + Stream.Read(j, sizeof(j)); + SetLength(DllMethod.Params, j); + For j := 0 To high(DllMethod.Params) Do + Begin + Stream.Read(TempSize, SizeOf(TempSize)); + Stream.Read(IntType, SizeOf(IntType)); + DllMethod.Params[j].TypeData := TRutisVarType.Create; + ScriptData.AddDeclaration(DllMethod.Params[j].TypeData, '$SYSTEM'); + DllMethod.Params[j].TypeData.Size := TempSize; + TRutisVarType(DllMethod.Params[j].TypeData).IntType := IntType; + End; + Stream.Read(TempSize, SizeOf(TempSize)); + Stream.Read(IntType, SizeOf(IntType)); + If TempSize > 0 Then + Begin + DllMethod.MethodResult.TypeData := TRutisVarType.Create; + ScriptData.AddDeclaration(DllMethod.MethodResult.TypeData, '$SYSTEM'); + DllMethod.MethodResult.TypeData.Size := TempSize; + TRutisVarType(DllMethod.MethodResult.TypeData).IntType := IntType; + End; + End; + End; + + //=========================================== + If StreamReadString(Stream) <> '#RESOURCES#' Then exit; + + ScriptData.Ressources.Free; + Stream.Read(i, 4); + ScriptData.Ressources := TRutisStack.Create(i); + + Stream.Read(i, 4); + SetLength(ScriptData.Ressources.Blocks, i); + With ScriptData.Ressources Do + For i := 0 To high(Blocks) Do + Begin + If Blocks[i].Data = nil Then + Blocks[i].Data := AllocMem(StackBlockSize); + Stream.Read(Blocks[i].Data^, StackBlockSize); + Stream.Read(Blocks[i].Top, 4); + End; + ScriptData.Ressources.TopBlock := high(ScriptData.Ressources.Blocks); + Stream.Read(ScriptData.Ressources.Top, sizeof(ScriptData.Ressources.Top)); + Stream.Read(ScriptData.Ressources.DecTop, sizeof(ScriptData.Ressources.DecTop)); + + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.SaveCodeToStream - Loaded compiled Script'));{$endif} +End; + +Procedure TRutisEngineBase.SaveBCodeToStream(Stream : TStream); +Var + i, j : Integer; + IsExtMethod : Boolean; + DllMethod : TRutisDllMethodType; + IntType : TRutisIntType; +Begin + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.SaveCodeToStream - Saving compiled Script'));{$endif} + StreamWriteString('Compiled RUTIS-Engine Script - (c) Björn Zeutzheim', Stream); + + StreamWriteString(ScriptData.ScriptName, Stream); + + //=========================================== + StreamWriteString('#CODEDATA#', Stream); + i := length(ScriptData.Code); + Stream.Write(i, sizeof(i)); + For i := 0 To high(ScriptData.Code) Do + Stream.Write(ScriptData.Code[i], sizeof(TRutisScriptCmd)); + + //=========================================== + StreamWriteString('#METHODINFOTABLE#', Stream); + i := length(ScriptData.MethodTable); + Stream.Write(i, sizeof(i)); + For i := 0 To high(ScriptData.MethodTable) Do + Begin + IsExtMethod := (ScriptData.MethodTable[i] is TRutisExtMethodType); + Stream.Write(IsExtMethod, sizeof(IsExtMethod)); + If IsExtMethod Then + With ScriptData.MethodTable[i] Do + Begin + StreamWriteString(Method_Name, Stream); + Stream.Write(MethodResult.Size, SizeOf(MethodResult.Size)); + Stream.Write(MethodResult.InternalType, SizeOf(MethodResult.InternalType)); + j := length(Params); + Stream.Write(j, SizeOf(j)); + For j := 0 To high(Params) Do + Begin + Stream.Write(Params[j].Size, SizeOf(Params[j].Size)); + Stream.Write(Params[j].InternalType, SizeOf(Params[j].InternalType)); + End; + End + Else + Begin + DllMethod := TRutisDllMethodType(ScriptData.MethodTable[i]); + StreamWriteString(DllMethod.DllName, Stream); + StreamWriteString(DllMethod.ProcName, Stream); + Stream.Write(DllMethod.ParamsSize, SizeOf(Word)); + Stream.Write(DllMethod.IsFunction, SizeOf(Boolean)); + j := length(DllMethod.Params); + Stream.Write(j, sizeof(j)); + For j := 0 To high(DllMethod.Params) Do + Begin + Stream.Write(DllMethod.Params[j].TypeData.Size, SizeOf(Word)); + IntType := DllMethod.Params[j].TypeData.InternalType; + Stream.Write(IntType, SizeOf(IntType)); + End; + Stream.Write(DllMethod.MethodResult.TypeData.Size, SizeOf(Word)); + IntType := DllMethod.MethodResult.TypeData.InternalType; + Stream.Write(IntType, SizeOf(IntType)); + End; + End; + + //=========================================== + StreamWriteString('#RESOURCES#', Stream); + Stream.Write(ScriptData.Ressources.StackBlockSize, 4); + i := length(ScriptData.Ressources.Blocks); + Stream.Write(i, 4); + With ScriptData Do + For i := 0 To high(ScriptData.Ressources.Blocks) Do + begin + Stream.Write(ScriptData.Ressources.Blocks[i].Data^, ScriptData.Ressources.StackBlockSize); + Stream.Write(ScriptData.Ressources.Blocks[i].Top, 4); + end; + Stream.Write(ScriptData.Ressources.Top, sizeof(ScriptData.Ressources.Top)); + Stream.Write(ScriptData.Ressources.DecTop, sizeof(ScriptData.Ressources.DecTop)); + + {$ifdef DEBUG}OutputDebugString(PChar('TRutisEngine.SaveCodeToStream - Saved compiled Script'));{$endif} +End; + +//============================================================================== + +Procedure TRutisEngineBase.LoadFromFile(FileName : String; CanReadProtected : Boolean = False); +Var + FS : TFileStream; +Begin + If not FileExists(FileName) Then exit; + FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + LoadFromStream(FS, CanReadProtected); + Finally + FS.Free; + End; +End; + +Procedure TRutisEngineBase.LoadScriptFromFile(FileName : String; CanReadProtected : Boolean = False); +Var + FS : TFileStream; +Begin + If not FileExists(FileName) Then exit; + FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + LoadScriptFromStream(FS, CanReadProtected); + Finally + FS.Free; + End; +End; + +Procedure TRutisEngineBase.SaveScriptToFile(FileName : String; SaveProtected : Boolean = False); +Var + FS : TFileStream; +Begin + FS := TFileStream.Create(FileName, fmCreate or fmShareExclusive); + Try + SaveScriptToStream(FS, SaveProtected); + Finally + FS.Free; + End; +End; + +Procedure TRutisEngineBase.LoadBCodeFromFile(FileName : String); +Var + FS : TFileStream; +Begin + If not FileExists(FileName) Then exit; + FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + LoadBCodeFromStream(FS); + Finally + FS.Free; + End; +End; + +Procedure TRutisEngineBase.SaveBCodeToFile(FileName : String); +Var + FS : TFileStream; +Begin + FS := TFileStream.Create(FileName, fmCreate or fmShareExclusive); + Try + SaveBCodeToStream(FS); + Finally + FS.Free; + End; +End; + +//============================================================================== +//============================================================================== + + { TRutisCompiler } + +Constructor TRutisCompiler.Create(AOwner : TRutisEngineBase); +Begin + Owner := AOwner; + + optArrayRangeCheck := True; + optArrangeFields := True; + optArrangeSize := 4; + + Owner.UnitFileManager.AddExtension('.rutis'); + //Owner.UnitFileManager.AddExtension('.pas'); +End; + +//============================================================================== + +Procedure TRutisCompiler.Compile; +Begin + ScriptData := Owner.ScriptData; + ScriptData.CompilerLine := 0; + ScriptData.CodeInsertPos := -1; +End; + +Procedure TRutisCompiler.Optimize; +Var + i : Integer; +// j,k : Integer; +// sng : Single; +Begin + i := 0; + //exit; + While i <= high(ScriptData.Code) Do + Begin + + If (i >= 0) and (i < high(ScriptData.Code)) and + (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = i + 1) Then + Begin + ScriptData.DeleteInstruction(i); + Dec(i); + Continue; + End; + + { + //There are Problems with In ... then structs + //If this optimizatiion occurs at the end of an If-Block with the last + //Action of the If and he first after the IF, the Stack changes size + If (i > 0) and (i < high(ScriptData.Code)) and + (ScriptData.Code[i-1].Cmd = _sto) and (ScriptData.Code[i].Cmd = _lod) and + (ScriptData.Code[i-1].P1 = ScriptData.Code[i].P1) and + (ScriptData.Code[i-1].P2 = ScriptData.Code[i].P2) and + (ScriptData.Code[i-1].P3 = ScriptData.Code[i].P3) then + begin + ScriptData.Code[i-1].Cmd := _Mov; + ScriptData.DeleteInstruction(i); + dec(i); + Continue; + end; + //} + + If (i >= 0) and (i < high(ScriptData.Code) - 2) and + (ScriptData.Code[i].Cmd = _gen4) and + (ScriptData.Code[i].P1 = 0) and + (ScriptData.Code[i + 1].Cmd = _gen4) and + (ScriptData.Code[i + 2].Cmd = _sub) Then + Begin + If TRutisIntType(ScriptData.Code[i + 2].P1) = intInteger Then + ScriptData.Code[i + 1].P1 := -ScriptData.Code[i + 1].P1; + If TRutisIntType(ScriptData.Code[i + 2].P1) = intSingle Then + PSingle(@ScriptData.Code[i + 1].P1)^ := -PSingle(@ScriptData.Code[i + 1].P1)^; + //Delete [gen4 0] + ScriptData.DeleteInstruction(i); + //Delete [sub] + ScriptData.DeleteInstruction(i + 1); + Dec(i); + Continue; + End; + //} + + { + //BUG with SetLength(TestArray[Index], Count) + If (i > 0) and + (ScriptData.Code[i - 1].Cmd = _lod) and + (ScriptData.Code[i].Cmd = _lodp) and + (ScriptData.Code[i].P1 = -4) and + (ScriptData.Code[i].P2 = -1) Then + Begin + ScriptData.Code[i - 1].Cmd := _lodp; + ScriptData.Code[i - 1].P3 := ScriptData.Code[i].P3; + ScriptData.DeleteInstruction(i); + Dec(i); + Continue; + End; + //} + { + //Not needed any more + If (ScriptData.Code[i].Cmd = _gen) and + (ScriptData.Code[i+1].Cmd = _gen) and + (ScriptData.Code[i+1].P1 = ScriptData.Code[i].P1) and + (ScriptData.Code[i+1].P2 = ScriptData.Code[i].P2) then + begin + j := 1; + k := ScriptData.Code[i+1].P3; + while (ScriptData.Code[i+j+1].Cmd = _gen) and + (ScriptData.Code[i+j+1].P1 = ScriptData.Code[i].P1) and + (ScriptData.Code[i+j+1].P2 = ScriptData.Code[i].P2) do + begin + k := k + ScriptData.Code[i+j+1].P3; + inc(j); + end; + ScriptData.Code[i].P3 := ScriptData.Code[i].P3+k; + for k := i+1 to i+j do + ScriptData.DeleteInstruction(i+1); + i := i + j; + end; + //} + + Inc(i); + End; +End; + +//============================================================================== +End. + diff --git a/Units/RUTIS/RUTIS_Compiler_Delphi.pas b/Units/RUTIS/RUTIS_Compiler_Delphi.pas new file mode 100644 index 0000000..d21a654 --- /dev/null +++ b/Units/RUTIS/RUTIS_Compiler_Delphi.pas @@ -0,0 +1,4178 @@ +{/============================================================================== +//============================================================================== + +RUTIS-Engine (RunTimeScript-Engine) + +RUTIS_Compiler_Delphi.pas (part of) RUTIS-Engine + +--> This unit contains the RUTIS-Compiler for Pascal-Syntax code + + +//============================================================================== + +Author : Björn Zeutzheim +E-Mail : bjoern@zeutzheim-boppard.de + +//============================================================================== + +License: Dieses Projekt (RUTIS-Engine) steht unter einer / + This project is licensed under the + Creative Commons 3.0 BY-NC-SA (German) License + +Diese Lizens beinhaltet / This license includes: +-> Namensnennung / Attribution +-> Keine kommerzielle Nutzung / Noncommercial +-> Weitergabe unter gleichen Bedingungen / Share Alike + +Ein ausformulierter Lizensvertrag ist über folgende Adresse erreichbar: +The Legal Code (the full license) can be read at the following Address: +> http: //creativecommons.org/licenses/by-nc-sa/3.0/de/ + +//============================================================================== +//==============================================================================} + +Unit RUTIS_Compiler_Delphi; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +Uses + Forms, Classes, +{$ifdef DELPHI_7_UP}Variants,{$endif} + SysUtils, Math, + Rutis_Defs, Rutis_Errors, RUTIS_Classes; + +Type +//============================================================================== +//============================================================================== + TRutisSymbol = (sUnknown, sIdent, sInteger, sFloat, sString, + sPlus, sMinus, sStar, sSlash, sMod, sDiv, sNil, + sEqual, sSmaller, sBigger, sBiggerEqual, sSmallerEqual, sUnEqual, + sOpenBracket, sCloseBracket, sOpenBracketR, sCloseBracketR, sComma, sDot, + sSemiColon, sBecomes, sDopDot, sHook, sAt, + sPacked, sRecord, + sSet, sArray, sClass, + sTrue, sFalse, + sProgram, sUnit, sInterface, sImplement, sInitialization, sFinalization, + sUses, sType, sVar, sConst, sOf, + sProcedure, sFunction, sExternal, + sIf, sThen, sElseIf, sElse, sBegin, sEnd, + sWhile, sDo, SRepeat, sUntil, sfor, + sTo, sDownTo, sContinue, sBreak, sExit, sTerminate, + sopAnd, sopOr, sopXOr, sopNot, + sInc, sDec, sWrite, sLength, sHigh, sSetLength, sSizeOf, + sGenMem, sReallocMem, sFreeMem, sMemSize, sNew, sDispose, + sNop, sNone); + + TRutisSymbols = Set Of TRutisSymbol; + +Const + cSymbols : Array[TRutisSymbol] Of ShortString = ('', '', '', '', '', + '+', '-', '*', '/', 'MOD', 'DIV', 'NIL', + '=', '<', '>', '>=', '<=', '<>', + '(', ')', '[', ']', ',', '.', + ';', ':=', ':', '^', '@', + 'PACKED', 'RECORD', + 'SET', 'ARRAY', 'CLASS', + 'TRUE', 'FALSE', + 'PROGRAM', 'UNIT', 'INTERFACE', 'IMPLEMENTATION', 'INITIALIZATION', 'FINALIZATION', + 'USES', 'TYPE', 'VAR', 'CONST', 'OF', + 'PROCEDURE', 'FUNCTION', 'EXTERNAL', + 'IF', 'THEN', 'ELSEIF', 'ELSE', 'BEGIN', 'END', + 'WHILE', 'DO', 'REPEAT', 'UNTIL', 'FOR', + 'TO', 'DOWNTO', 'CONTINUE', 'BREAK', 'EXIT', 'TERMINATE', + 'AND', 'OR', 'XOR', 'NOT', + 'INC', 'DEC', 'WRITE', 'LENGTH', 'HIGH', 'SETLENGTH', 'SIZEOF', + 'GENMEM', 'REALLOCMEM', 'FREEMEM', 'MEMSIZE', 'NEW', 'DISPOSE', + 'NOP', ''); + +Const + errSymbols : Array[TRutisSymbol] Of ShortString = + ('Unknown', 'Identifier', 'Integer', 'Float', 'String', + '+', '-', '*', '/', 'mod', 'div', 'nil', + '=', '<', '>', '>=', '<=', '<>', + '(', ')', '[', ']', 'Comma', 'Dot', + 'Semicolon', ':=', ':', '^', '@', + 'packed', 'RECORD', + 'SET', 'ARRAY', 'CLASS', + 'TRUE', 'FALSE', + 'PROGRAM', 'UNIT', 'INTERFACE', 'IMPLEMENTATION', 'INITIALIZATION', 'FINALIZATION', + 'USES', 'TYPE', 'VAR', 'CONST', 'OF', + 'PROCEDURE', 'FUNCTION', 'EXTERNAL', + 'IF', 'THEN', 'ElseIf', 'else', 'BEGIN', 'END', + 'WHILE', 'DO', 'REPEAT', 'UNTIL', 'FOR', + 'To', 'DownTo', 'Continue', 'Break', 'Exit', 'Terminate', + 'AND', 'OR', 'XOR', 'NOT', + 'inc', 'dec', 'write', 'length', 'high', 'SetLength', 'SizeOf', + 'GenMem', 'ReallocMem', 'FreeMem', 'MemSize', 'New', 'Dispose', + 'NOP', '!none!'); + +Type + TCompilerState = Record + CSScannerLine : Integer; + CSScannerStrPos : Integer; + CSScannerCh : Char; + CSIdentSym : TRutisSymbol; + CSCodePos : Integer; + End; + + TRutisResStringInfo = Record + Address : Integer; + Value : AnsiString; + End; + + TRutisCompilerDelphi = Class(TRutisCompiler) + Private + Protected + StackVarPos : Integer; + UnitNamespaces : Array Of AnsiString; + CompiledUnits : Array Of AnsiString; + ResStrings : Array Of TRutisResStringInfo; + CurrentNamespace : AnsiString; + CurrentUnit : AnsiString; + CompilingUnit : Boolean; + fCompilerLevel : Integer; + InitializationJmp, + FinalizationJmpPos : Integer; + fCompilingDefines : Boolean; + ExitParamsSize : Integer; + LoopDepth : Smallint; + //======================== + ScannerLine : Integer; + ScannerStrPos : Integer; + LastScannerLine : Integer; + LastScannerStrPos : Integer; + ScannerCh : Char; + IdentSym : TRutisSymbol; + IdentStr : ShortString; + IdentNum : Variant; + ExprResult : TRutisTypeDecl; + //======================== + PushScannerLine : Integer; + PushScannerStrPos : Integer; + PushScannerCh : Char; + PushIdentSym : TRutisSymbol; + CompilerStates : Array Of TCompilerState; + //======================== + Procedure CompilerMessage(Const Msg : AnsiString; Const Args : Array Of Const; ErrorType : TRutisErrorType = etCompilerError); Overload; + Procedure CompilerMessage(Msg : AnsiString; ErrorType : TRutisErrorType = etCompilerError); Overload; + //======================== + Procedure GetSym; + Procedure PushScanner; + Procedure PopScanner; + Procedure PopCompilerState; + Procedure PushCompilerState; + //======================== + Procedure RaiseError(Const Msg : AnsiString); Overload; + Procedure RaiseError(Const Msg : AnsiString; Const Args : Array Of Const); Overload; + Procedure ErrorExpected(Expected : TRutisSymbols; Found : TRutisSymbol); + Function Expect(Expected : TRutisSymbols) : Boolean; + //======================== + Function CheckRedefinition(Name : AnsiString) : Boolean; + Function GetDeclaration(Name : AnsiString) : TRutisDecl; Overload; + Function GetDeclaration(Name : AnsiString; Exclude : Array Of TRutisDecl) : TRutisDecl; Overload; + Function GetDeclarationID(Name : AnsiString) : Integer; Overload; + //======================== + Procedure GenLoadSaveCode(AType : TIdentType; Address, Level, Size : Integer; DoLoad : Boolean); Overload; + Procedure GenLoadSaveCode(AType : TIdentType; Address, Level : Integer; AIntType : TRutisIntType; DoLoad : Boolean); Overload; + //======================== + Procedure C_Program; + Procedure C_Unit; + Procedure C_Uses; + //=== Find / Analyse Types === + Function GetPointerType(AType : TRutisTypeDecl; WantedName : AnsiString = '') : TRutisPointerType; + Function GetArrayType(AType : TRutisTypeDecl; WantedName : AnsiString = '') : TRutisArrayType; + Function GetSetType(AType : TRutisEnumType; WantedName : AnsiString = '') : TRutisSetType; + Function C_DeclTypeInline(NewTypeName : AnsiString = '') : TRutisTypeDecl; + //=== Declarations === + Procedure C_DeclType; + Procedure C_DeclTypes; + Procedure C_DeclParams; + Procedure C_DeclVars; + Procedure C_DeclMethod; + Procedure C_DeclConsts; + Function C_DeclarationSeq : Boolean; + Procedure C_Declarations; + //======================== + Function C_Method : Boolean; + Procedure C_Implementation; + //======================== + Function C_AnalyzeIdent(IsExpression : Boolean; WantType : TRutisIntType; Var Inf : TAnalyzeIdentInfo) : TIdentType; + //======================== + procedure C_Expression(WantType : TRutisTypeDecl); + //Function C_Expression(WantType : TRutisIntType; WantTypeDecl : TRutisTypeDecl = nil) : Boolean; + //procedure C_StrExpression; + //======================== + Procedure C_StatementSequence; + Public + Constructor Create(AOwner : TRutisEngineBase); + Destructor Destroy; Override; + //======================== + Procedure Compile; Override; + End; + + //============================================================================== + //============================================================================== +Implementation + +//============================================================================== +//============ TRutisCompilerDelphi ============================================ +//============================================================================== + +Constructor TRutisCompilerDelphi.Create(AOwner : TRutisEngineBase); +Begin + Inherited; + + optArrangeFields := True; + optArrangeSize := 8; +End; + +Destructor TRutisCompilerDelphi.Destroy; +Begin + Inherited; +End; + +Procedure TRutisCompilerDelphi.Compile; +Var + oldDecimalSeparator : Char; + I, j : Integer; + tmpDecl : TRutisDecl; +Begin + Inherited Compile; + + oldDecimalSeparator := DecimalSeparator; + DecimalSeparator := '.'; + + CurrentUnit := ''; + + ScriptData.CompilerLine := 0; + IdentNum := 0; + IdentStr := ''; + ScannerCh := #0; + ScannerStrPos := 0; + ScannerLine := -1; + FinalizationJmpPos := -5; + fCompilerLevel := 0; + StackVarPos := 0; + LoopDepth := 0; + SetLength(CompiledUnits, 0); + SetLength(UnitNamespaces, 0); + SetLength(ResStrings, 0); + + For I := 0 To ScriptData.DeclarationCount - 1 Do + If (ScriptData.DeclarationList[i] is TRutisExtMethodType) Then + Begin + tmpDecl := ScriptData.DeclarationList[i]; + TRutisExtMethodType(tmpDecl).MethodTableID := -1; + TRutisExtMethodType(tmpDecl).MethodResult.TypeData := nil; + For j := 0 To high(TRutisExtMethodType(tmpDecl).Params) Do + TRutisExtMethodType(tmpDecl).Params[j].TypeData := nil; + End; + + Try + {$ifdef DEBUG}OutputDebugString('TRutisCompilerDelphi.Compile - Compiling...');{$endif DEBUG} + C_Program; + + Owner.CompilerMessage('Script sucessfully compiled!', etHint); + Owner.CompilerMessage('Raw CMD-count :' + IntToStr(length(ScriptData.Code)), etHint); + {$ifdef DEBUG}OutputDebugString('TRutisCompilerDelphi.Compile - Optimizing...');{$endif DEBUG} + Optimize; + Owner.CompilerMessage('Optimized CMD-count :' + IntToStr(length(ScriptData.Code)), etHint); + Finally + DecimalSeparator := oldDecimalSeparator; + End; +End; + +//============================================================================== + +Procedure TRutisCompilerDelphi.CompilerMessage(Const Msg : AnsiString; Const Args : Array Of Const; ErrorType : TRutisErrorType); +Begin + Try + CompilerMessage(Format(Msg, Args), ErrorType); + Except + on EConvertError Do + Begin + CompilerMessage('Wrong Arguments'); + End; + End; +End; + +Procedure TRutisCompilerDelphi.CompilerMessage(Msg : AnsiString; ErrorType : TRutisErrorType); +Begin + If ErrorType = etCompilerError Then + Msg := 'Error: ' + CurrentNamespace + '(' + IntToStr(ScriptData.CompilerLine + 1) + '): ' + Msg; + If ErrorType = etWarning Then + Msg := 'Warning: ' + CurrentNamespace + '(' + IntToStr(ScriptData.CompilerLine + 1) + '): ' + Msg; + If ErrorType = etHint Then + Msg := 'Hint: ' + CurrentNamespace + '(' + IntToStr(ScriptData.CompilerLine + 1) + '): ' + Msg; + + Owner.CompilerMessage(Msg, ErrorType); +End; + +Procedure TRutisCompilerDelphi.RaiseError(Const Msg : AnsiString; Const Args : Array Of Const); +Begin + Raise ERutisCompilerError.CreateFmt(Msg, Args, CurrentNamespace, LastScannerLine, LastScannerStrPos); +End; + +Procedure TRutisCompilerDelphi.RaiseError(Const Msg : AnsiString); +Begin + Raise ERutisCompilerError.Create(Msg, CurrentNamespace, LastScannerLine, LastScannerStrPos); +End; + +Procedure TRutisCompilerDelphi.ErrorExpected(Expected : TRutisSymbols; Found : TRutisSymbol); +Var + SymStr : AnsiString; + GotOne : Boolean; + sym : TRutisSymbol; +Begin + SymStr := ''; + GotOne := False; + For sym := sUnknown To sNone Do + If sym in Expected Then + Begin + If GotOne Then + SymStr := SymStr + ''', ''' + errSymbols[sym] + Else + SymStr := errSymbols[sym]; + End; + RaiseError(ERR_EXPECTED_FOUND, [SymStr, errSymbols[Found]]); +End; + +Function TRutisCompilerDelphi.Expect(Expected : TRutisSymbols) : Boolean; +Begin + Result := True; + If IdentSym in Expected Then exit; + ErrorExpected(Expected, IdentSym); + Result := False; +End; + +//============================================================================== +//============================================================================== + +Procedure TRutisCompilerDelphi.GenLoadSaveCode(AType : TIdentType; Address, Level, Size : Integer; DoLoad : Boolean); +Begin + If DoLoad Then + Begin + Case AType Of + itVar : ScriptData.GenCode(_lod, Address, Level, Size); + itPVar : ScriptData.GenCode(_lodp, Address, Level, Size); + itConst : ScriptData.GenCode(_lodr, Address, Size, 0); + itError : RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); + itMethod : + Begin + //CompilerError(ERR_VAR_EXPECTED); + exit; + End; + End; + End + Else + Case AType Of + itVar : ScriptData.GenCode(_sto, Address, Level, Size); + itPVar : If Level < 0 Then + ScriptData.GenCode(_stop, Address - 3 - Size, Level, Size) + Else + ScriptData.GenCode(_stop, Address, Level, Size); + itConst : RaiseError(ERR_NO_CONST_ALLOWED); + itError : RaiseError(Format(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)])); + itMethod : RaiseError(ERR_VAR_EXPECTED); + End; +End; + +Procedure TRutisCompilerDelphi.GenLoadSaveCode(AType : TIdentType; Address, Level : Integer; AIntType : TRutisIntType; DoLoad : Boolean); +Var Size : Integer; +Begin + Size := IntTypeSizes[AIntType]; + If Size < 0 Then RaiseError(ERR_UNEXPECTED_ERROR); + If DoLoad Then + Begin + Case AType Of + itVar : ScriptData.GenCode(_lod, Address, Level, Size); + itPVar : If Level < 0 Then + ScriptData.GenCode(_lodp, Address - 3, Level, Size) + Else + ScriptData.GenCode(_lodp, Address, Level, Size); + itConst : ScriptData.GenCode(_lodr, Address, Size, 0); + itError : RaiseError(Format(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)])); + itMethod : RaiseError(ERR_VAR_EXPECTED); + End; + End + Else + Case AType Of + itVar : ScriptData.GenCode(_sto, Address, Level, Size); + itPVar : If Level < 0 Then + ScriptData.GenCode(_stop, Address - 3 - Size, Level, Size) + Else + ScriptData.GenCode(_stop, Address, Level, Size); + itConst : RaiseError(ERR_NO_CONST_ALLOWED); + itError : RaiseError(Format(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)])); + itMethod : RaiseError(ERR_VAR_EXPECTED); + End; +End; + +//============================================================================== + +Procedure TRutisCompilerDelphi.C_Program; +Var + str : AnsiString; + Namespace : TRutisNamespace; +Begin + GetSym; + If IdentSym = sUnit Then + Begin + InitializationJmp := -1; + ScannerStrPos := 0; + ScriptData.CompilerLine := 0; + C_Unit; + If not optCanCompileUnits then + SetLength(ScriptData.Code, 0); + exit; + End; + + Expect([sProgram]); + GetSym; + Expect([sIdent]); + If CurrentUnit <> '' Then + If UpperCase(CurrentUnit) <> UpperCase(IdentStr) Then + Begin + CompilerMessage(ERR_FILENAME_NOT_UNITNAME, etWarning); + exit; + End; + CurrentUnit := IdentStr; + CurrentNamespace := CurrentUnit; + ScriptData.ScriptName := IdentStr; + + Namespace := ScriptData.GetNamespace(CurrentUnit); + If Namespace = nil Then + Begin + Namespace := TRutisNamespace.Create; + SetLength(ScriptData.Namespaces, Length(ScriptData.Namespaces) + 1); + ScriptData.Namespaces[high(ScriptData.Namespaces)] := Namespace; + Namespace.Name := UpperCase(CurrentUnit); + Namespace.CodeFile := CurrentUnit; + Namespace.CodeStart := 0; + End; + + SetLength(UnitNamespaces, 1); + UnitNamespaces[0] := CurrentNamespace; + + GetSym; + Expect([sSemiColon]); + GetSym; + Expect([sInterface]); + GetSym; + ScriptData.CompilerLine := ScannerLine; + + ScriptData.GenCode(_gen, 0, 0, 0); + ScriptData.GenCode(_jmp, 0, 0, 0); + InitializationJmp := high(ScriptData.Code); + + str := ScriptData.ScriptName; + C_Uses; + ScriptData.ScriptName := str; + + fCompilingDefines := True; + C_Declarations; + fCompilingDefines := False; + ScriptData.CompilerLine := ScannerLine; + + Expect([sImplement]); + GetSym; + ScriptData.CompilerLine := ScannerLine; + + C_Implementation; + + ScriptData.Code[0].P1 := StackVarPos; + + ScriptData.CompilerLine := ScannerLine; + Expect([sBegin]); + GetSym; + + ScriptData.Code[InitializationJmp].P1 := Length(ScriptData.Code); + + C_StatementSequence; + + ScriptData.CompilerLine := ScannerLine; + Expect([sEnd]); + GetSym; + Expect([sDot]); + + //Und Ende... + ScriptData.GenCode(_jmp, FinalizationJmpPos, 0, 0); + + Namespace.CodeEnd := Length(ScriptData.Code); + + GetSym; + If IdentSym <> sNone Then + CompilerMessage(ERR_CODE_AFTER_PROGRAM_END, etHint); + + {$ifdef DEBUG}OutputDebugString(PAnsiChar('TRutisCompilerDelphi.C_Program - Compiled Program ' + ScriptData.ScriptName));{$endif DEBUG} +End; + +Procedure TRutisCompilerDelphi.C_Unit; +Var + int : Integer; + str : AnsiString; + Namespace : TRutisNamespace; + IsUnitApp : Boolean; +Begin + CompilingUnit := True; + + If length(ScriptData.Code) = 0 Then + Begin + ScriptData.GenCode(_gen, 0, 0, 0); + ScriptData.GenCode(_jmp, 0, 0, 0); + InitializationJmp := high(ScriptData.Code); + IsUnitApp := true; + End + else + IsUnitApp := false; + + GetSym; + Expect([sUnit]); + GetSym; + Expect([sIdent]); + If CurrentUnit <> '' Then + If UpperCase(CurrentUnit) <> UpperCase(IdentStr) Then + Begin + RaiseError(ERR_FILENAME_NOT_UNITNAME); + exit; + End; + CurrentUnit := IdentStr; + CurrentNamespace := CurrentUnit; + If IsUnitApp then + ScriptData.ScriptName := IdentStr; + + Namespace := ScriptData.GetNamespace(CurrentUnit); + If Namespace = nil Then + Begin + Namespace := TRutisNamespace.Create; + SetLength(ScriptData.Namespaces, Length(ScriptData.Namespaces) + 1); + ScriptData.Namespaces[high(ScriptData.Namespaces)] := Namespace; + Namespace.Name := UpperCase(CurrentUnit); + Namespace.CodeFile := CurrentUnit; + Namespace.CodeStart := 0; + End; + + SetLength(UnitNamespaces, 1); + UnitNamespaces[0] := CurrentNamespace; + + GetSym; + Expect([sSemiColon]); + GetSym; + Expect([sInterface]); + GetSym; + //ScriptData.CompilerLine := ScannerLine; + + //{!!}Owner.OnError(CurrentUnit + ': C_Unit -> C_Uses', etHint); + str := ScriptData.ScriptName; + C_Uses; + ScriptData.ScriptName := str; + + //{!!}Owner.OnError(CurrentUnit + ': C_Unit -> C_Declarations', etHint); + fCompilingDefines := True; + C_Declarations; + fCompilingDefines := False; + + //ScriptData.GenCode(_jmp, 0, 0, 0); + //InitializationJmp := high(ScriptData.Code); + + Expect([sImplement]); + GetSym; + + //{!!}Owner.OnError(CurrentUnit + ': C_Unit -> C_Implementation', etHint); + C_Implementation; + //{!!}Owner.OnError(CurrentUnit + ': C_Unit <- C_Implementation', etHint); + + If IdentSym = sInitialization Then + Begin + GetSym; + ScriptData.Code[InitializationJmp].P1 := high(ScriptData.Code) + 1; + C_StatementSequence; + ScriptData.GenCode(_jmp, 0, 0, 0); + InitializationJmp := high(ScriptData.Code); + + If IdentSym = sFinalization Then + Begin + GetSym; + int := high(ScriptData.Code) + 1; + C_StatementSequence; + ScriptData.GenCode(_jmp, FinalizationJmpPos, 0, 0); + FinalizationJmpPos := int; + End; + End; + ScriptData.Code[InitializationJmp].P1 := high(ScriptData.Code) + 1; + + If IsUnitApp then + ScriptData.Code[0].P1 := StackVarPos; + + Namespace.CodeEnd := Length(ScriptData.Code); + + Expect([sEnd]); + GetSym; + Expect([sDot]); + + GetSym; + If IdentSym <> sNone Then + CompilerMessage(ERR_CODE_AFTER_UNIT_END, etHint); + + CompilingUnit := False; + + {$ifdef DEBUG}OutputDebugString(PAnsiChar('TRutisCompilerDelphi.C_Unit - Compiled Unit ' + ScriptData.ScriptName));{$endif DEBUG} +End; + +Procedure TRutisCompilerDelphi.C_Uses; +Var + i : Integer; + UName : AnsiString; + savCurrUnit : AnsiString; + savScriptCode : TStrings; + savScannerStrPos : Integer; + savLine : Integer; + savScannerLine : Integer; + savScannerCh : Char; + savIdentSym : TRutisSymbol; + savIdentStr : ShortString; + savIdentNum : Variant; + savUnitNamespaces : Array Of AnsiString; + UnitNames : Array Of AnsiString; + j : Integer; +Begin + If IdentSym = sUses Then + Begin + SetLength(savUnitNamespaces, Length(UnitNamespaces)); + For i := 0 To high(UnitNamespaces) Do + savUnitNamespaces[i] := UnitNamespaces[i]; + + SetLength(UnitNames, 0); + Repeat + GetSym; + ScriptData.CompilerLine := ScannerLine; + Expect([sIdent]); + SetLength(UnitNames, Length(UnitNames) + 1); + UnitNames[high(UnitNames)] := IdentStr; + GetSym; + Until IdentSym <> sComma; + Expect([sSemiColon]); + GetSym; + ScriptData.CompilerLine := ScannerLine; + + savCurrUnit := CurrentUnit; + savScriptCode := ScriptCode; + savScannerStrPos := ScannerStrPos; + savLine := ScriptData.CompilerLine; + savScannerLine := ScannerLine; + savScannerCh := ScannerCh; + savIdentSym := IdentSym; + savIdentStr := IdentStr; + savIdentNum := IdentNum; + + ScriptCode := TStringList.Create; + Try + For i := 0 To high(UnitNames) Do + Begin + UnitNames[i] := lowerCase(UnitNames[i]); + For j := 0 To high(CompiledUnits) Do + If CompiledUnits[j] = UnitNames[i] Then + Break; + If j <= high(CompiledUnits) Then + If CompiledUnits[j] = UnitNames[i] Then + Continue; + + SetLength(CompiledUnits, length(CompiledUnits) + 1); + CompiledUnits[high(CompiledUnits)] := UnitNames[i]; + + UName := Owner.UnitFileManager.SearchFile(UnitNames[i]); + If not FileExists(UName) Then + Begin + RaiseError(ERR_UNIT_NOT_FOUND, [UnitNames[i]]); + exit; + End; + ScriptCode.LoadFromFile(UName); + + SetLength(UnitNamespaces, 0); + IdentSym := sNone; + IdentStr := ''; + IdentNum := 0; + ScannerCh := #0; + ScannerStrPos := 0; + ScriptData.CompilerLine := 0; + ScannerLine := -1; + CurrentUnit := ExtractFileName(UName); + If Pos('.', CurrentUnit) > 0 Then + CurrentUnit := copy(CurrentUnit, 1, Pos('.', CurrentUnit) - 1); + + C_Unit; + End; + Finally + ScriptCode.Free; + End; + + ScriptCode := savScriptCode; + ScannerStrPos := savScannerStrPos; + ScriptData.CompilerLine := savLine; + ScannerLine := savScannerLine; + ScannerCh := savScannerCh; + IdentSym := savIdentSym; + IdentStr := savIdentStr; + IdentNum := savIdentNum; + CurrentUnit := savCurrUnit; + CurrentNamespace := CurrentUnit; + + SetLength(UnitNamespaces, Length(UnitNames) + Length(savUnitNamespaces)); + For i := 0 To high(UnitNames) Do + UnitNamespaces[i] := UnitNames[i]; + For i := 0 To high(savUnitNamespaces) Do + UnitNamespaces[i + length(UnitNames)] := savUnitNamespaces[i]; + End; +End; + +//============================================================================== +//============================================================================== + +Function TRutisCompilerDelphi.GetPointerType(AType : TRutisTypeDecl; WantedName : AnsiString) : TRutisPointerType; +Var + i, j : Integer; +Begin + For i := 0 To high(ScriptData.Namespaces) Do + For j := 0 To high(ScriptData.Namespaces[i].Declarations) Do + If ScriptData.Namespaces[i].Declarations[j] is TRutisPointerType Then + If TRutisPointerType(ScriptData.Namespaces[i].Declarations[j]).PointerType = AType Then + Begin + Result := TRutisPointerType(ScriptData.Namespaces[i].Declarations[j]); + exit; + End; + // No matching Pointer-Type found so create one + Result := TRutisPointerType.Create; + If (WantedName = '') Then + Result.Name := 'P' + AType.Name + '_auto' + Else + Result.Name := WantedName; + Result.PointerType := AType; + Result.ExplicitCast := False; + ScriptData.AddDeclaration(Result, '$SYSTEM'); +End; + +Function TRutisCompilerDelphi.GetArrayType(AType : TRutisTypeDecl; WantedName : AnsiString) : TRutisArrayType; +Var + i, j : Integer; +Begin + For i := 0 To high(ScriptData.Namespaces) Do + For j := 0 To high(ScriptData.Namespaces[i].Declarations) Do + If ScriptData.Namespaces[i].Declarations[j] is TRutisArrayType Then + If TRutisArrayType(ScriptData.Namespaces[i].Declarations[j]).ArrayType = AType Then + Begin + Result := TRutisArrayType(ScriptData.Namespaces[i].Declarations[j]); + exit; + End; + // No matching Pointer-Type found so create one + Result := TRutisArrayType.Create; + If (WantedName = '') Then + Result.Name := 'T' + AType.Name + 'Array_auto' + Else + Result.Name := WantedName; + Result.ArrayType := AType; + Result.ExplicitCast := True; + ScriptData.AddDeclaration(Result, '$SYSTEM'); +End; + +Function TRutisCompilerDelphi.GetSetType(AType : TRutisEnumType; WantedName : AnsiString) : TRutisSetType; +Var + i, j : Integer; +Begin + For i := 0 To high(ScriptData.Namespaces) Do + For j := 0 To high(ScriptData.Namespaces[i].Declarations) Do + If ScriptData.Namespaces[i].Declarations[j] is TRutisSetType Then + If TRutisSetType(ScriptData.Namespaces[i].Declarations[j]).EnumType = AType Then + Begin + Result := TRutisSetType(ScriptData.Namespaces[i].Declarations[j]); + exit; + End; + // No matching Pointer-Type found so create one + Result := TRutisSetType.Create; + If (WantedName = '') Then + Result.Name := 'T' + AType.Name + 's_auto' + Else + Result.Name := WantedName; + Result.EnumType := AType; + Result.ExplicitCast := True; + ScriptData.AddDeclaration(Result, '$SYSTEM'); + + Result.Size := 1; + For I := 0 To high(Result.EnumType.Enums) Do + If Result.EnumType.Enums[i].Value >= Result.Size * 8 Then + Begin + Case Result.Size Of + 2 : Result.Size := 4; + 4 : Result.Size := 8; + Else + Inc(Result.Size); + End; + End; +End; + +//============================================================================== + +Function TRutisCompilerDelphi.C_DeclTypeInline(NewTypeName : AnsiString = '') : TRutisTypeDecl; +Var + TypeDecl : TRutisTypeDecl; + ExplicitCast : Boolean; + + Function GetEnumType : TRutisTypeDecl; + Var + int, i : Integer; + Bool : Boolean; + VarDecl : TRutisVarDecl; + Begin + GetSym; + Result := TRutisEnumType.Create; + + If NewTypeName <> '' Then + Result.Name := NewTypeName + Else + Result.Name := 'TEnum_ID' + IntToStr(random(1024)); + ScriptData.AddDeclaration(Result, CurrentNamespace); + + Result.Size := 1; + With TRutisEnumType(Result) Do + Begin + While True Do + Begin + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + + VarDecl := TRutisVarDecl.Create; + VarDecl.Name := IdentStr; + ScriptData.AddDeclaration(VarDecl, CurrentNamespace); + + VarDecl.IsConst := True; + VarDecl.Level := 0; + VarDecl.Address := ScriptData.Ressources.Top; + VarDecl.VarType := Result; + + GetSym; + If IdentSym = sEqual Then + Begin + GetSym; + Expect([sInteger]); + int := 0; + For I := 0 To high(Enums) Do + If Enums[i].Value = int Then + RaiseError('The value %d already exists in this enumaration type', [int]); + End + Else + Begin + int := 0; + Repeat + Bool := True; + For I := 0 To high(Enums) Do + If Enums[i].Value = int Then + Begin + Bool := False; + Inc(int); + End; + Until Bool; + End; + If int < 0 Then + RaiseError('The enum-value ''%d'' is too low. It needs to be positive.', [int]); + If int >= 32 Then + RaiseError('The enum-value ''%d'' is too big. It needs to be lower than 32.', [int]); + + SetLength(Enums, length(Enums) + 1); + Enums[high(Enums)].Name := VarDecl.Name; + Enums[high(Enums)].Value := int; + ScriptData.Ressources.PushByte(int); + + If IdentSym = sCloseBracket Then break; + Expect([sComma]); + GetSym; + End; + End; + GetSym; + End; + +Begin + Result := nil; + ExplicitCast := False; + + If IdentSym = sType Then + Begin + ExplicitCast := True; + GetSym; + End; + + // Enum-Types + If IdentSym = sOpenBracket Then + Begin + Result := GetEnumType; + exit; + End; + + // Set-Types + If IdentSym = sSet Then + Begin + GetSym; + Expect([sOf]); + GetSym; + TypeDecl := C_DeclTypeInline(); + If not (TypeDecl is TRutisEnumType) Then + RaiseError(ERR_NEEDED_FOUND, [RutisVarTypeTOString[intEnum], RutisVarTypeTOString[TypeDecl.InternalType]]); + + Result := GetSetType(TRutisEnumType(TypeDecl), NewTypeName); + exit; + End; + + If IdentSym = sArray Then + Begin + GetSym; + Expect([sOf]); + GetSym; + TypeDecl := C_DeclTypeInline(); + + Result := GetArrayType(TypeDecl, NewTypeName); + exit; + End; + + If IdentSym = sHook Then + Begin + GetSym; + TypeDecl := C_DeclTypeInline(); + + Result := GetPointerType(TypeDecl, NewTypeName); + Result.ExplicitCast := ExplicitCast; + exit; + End; + + Expect([sIdent]); + + Result := TRutisTypeDecl(GetDeclaration(IdentStr)); + If Result = nil Then + Begin + RaiseError(ERR_UNKNOWN_IDENT, [IdentStr]); + exit; + End; + If not (Result is TRutisTypeDecl) Then + Begin + RaiseError(ERR_TYPE_EXPECTED); + exit; + End; + + GetSym; + + If (NewTypeName <> '') and (NewTypeName <> Result.Name) Then + Begin + TypeDecl := TRutisTypeCopy.Create; + TypeDecl.Name := NewTypeName; + TypeDecl.ExplicitCast := ExplicitCast; + TRutisTypeCopy(TypeDecl).CopyType := Result; + TRutisTypeCopy(TypeDecl).Size := Result.Size; + + //ScriptData.AddDeclaration(TypeDecl, '$SYSTEM'); + ScriptData.AddDeclaration(TypeDecl, CurrentNamespace); + Result := TypeDecl; + End; +End; + +Procedure TRutisCompilerDelphi.C_DeclType; +Var + int, i, j : Integer; + RasterSize : Byte; + TypeName : AnsiString; + VType : TRutisTypeDecl; + Parent : TRutisStructType; + StructType : TRutisStructType; + AClassType : TRutisClassType; + ParentClass : TRutisClassType; + VarNames : Array Of AnsiString; + fIsPacked : Boolean; +Begin + Expect([sIdent]); + + TypeName := IdentStr; + If CheckRedefinition(TypeName) Then + Begin + i := ScriptData.GetDeclarationId(TypeName, '$STATIC'); + If i >= 0 Then + Begin + {Repeat + GetSym; + If IdentSym = sRecord Then + Begin + Repeat + GetSym; + Until IdentSym in [sEnd, sNone, sUnknown]; + End; + Until IdentSym in [sSemiColon, sNone, sUnknown]; + GetSym; + exit; } + End + Else + Begin + RaiseError(ERR_INDENT_REDEFINED, [TypeName]); + exit; + End; + End; + GetSym; + + Expect([sEqual]); + GetSym; + + If IdentSym = sPacked Then + Begin + fIsPacked := True; + GetSym; + End + Else + fIsPacked := False; + + If IdentSym = sExternal Then + Begin + GetSym; + Expect([sClass]); + GetSym; + + StructType := TRutisStructType.Create; + ScriptData.AddDeclaration(StructType, CurrentNamespace); + With StructType Do + Begin + Name := TypeName + '_CLASSDATA'; + IsPacked := fIsPacked; + + If IdentSym = sOpenBracket Then + Begin + GetSym; + Expect([sIdent]); + + ParentClass := GetDeclaration(IdentStr) as TRutisClassType; + If not (ParentClass is TRutisClassType) Then + Begin + RaiseError('Class-Type expected'); exit; + End; + GetSym; + Expect([sCloseBracket]); + GetSym; + End + Else + ParentClass := Owner.decl_TObject; + + Parent := ParentClass.ClassStruct; + Size := Parent.Size; + fAlignSize := Parent.fAlignSize; + //IsPacked := Parent.IsPacked; + + SetLength(StructTypes, Length(TRutisStructType(Parent).StructTypes)); + For i := 0 To high(TRutisStructType(Parent).StructTypes) Do + Begin + StructTypes[i] := TRutisVarDecl.Create; + StructTypes[i].VarType := TRutisStructType(Parent).StructTypes[i].VarType; + StructTypes[i].Address := TRutisStructType(Parent).StructTypes[i].Address; + StructTypes[i].isConst := TRutisStructType(Parent).StructTypes[i].isConst; + StructTypes[i].Level := TRutisStructType(Parent).StructTypes[i].Level; + StructTypes[i].Name := TRutisStructType(Parent).StructTypes[i].Name; + End; + { + else + begin + SetLength(StructTypes, 1); + StructTypes[0] := TRutisVarDecl.Create; + StructTypes[0].VarType := Owner.decl_VMT; + StructTypes[0].Address := 0; + StructTypes[0].Name := 'VMT'; + Size := 4; + end; + } + + While True Do + Begin + SetLength(VarNames, 0); + While True Do + Begin + Expect([sIdent]); + SetLength(VarNames, Length(VarNames) + 1); + VarNames[High(VarNames)] := IdentStr; + GetSym; + If IdentSym <> scomma Then Break; + GetSym; + End; + Expect([sDopDot]); + GetSym; + + VType := C_DeclTypeInline(); + If VType = nil Then exit; + + int := high(StructTypes); + SetLength(StructTypes, Length(StructTypes) + Length(VarNames)); + + If optArrangeFields and not IsPacked Then + Begin + RasterSize := Max(Min(VType.AlignSize, optArrangeSize), 1); + fAlignSize := max(AlignSize, RasterSize); + j := RasterSize - (Size mod RasterSize); + If j < RasterSize Then + Begin + //ScriptData.GenCode(_gen, j, 0, 0); + Size := Size + j; + End; + End; + For i := int + 1 To high(StructTypes) Do + Begin + StructTypes[i] := TRutisVarDecl.Create; + StructTypes[i].VarType := VType; + StructTypes[i].Address := Size; + StructTypes[i].Name := VarNames[i - int - 1]; + Size := Size + VType.Size; + End; + + //GetSym; + Expect([sSemiColon]); + GetSym; + If not (IdentSym in [sIdent, sSemiColon]) Then break; + End; + If optArrangeFields and not IsPacked Then + Begin + j := AlignSize - (Size mod AlignSize); + If j < AlignSize Then + Begin + //ScriptData.GenCode(_gen, j, 0, 0); + Size := Size + j; + End; + End; + + Expect([sEnd]); + GetSym; + Expect([sSemiColon]); + GetSym; + End; + AClassType := TRutisClassType.Create; + AClassType.Name := TypeName; + AClassType.ClassStruct := StructType; + AClassType.IsExternal := True; + AClassType.ParentClass := ParentClass; + ScriptData.AddDeclaration(AClassType, CurrentNamespace); + exit; + End; + + If fIsPacked Then + Expect([sRecord]); + + If IdentSym = sRecord Then + Begin + GetSym; + + StructType := TRutisStructType.Create; + ScriptData.AddDeclaration(StructType, CurrentNamespace); + With StructType Do + Begin + Name := TypeName; + Size := 0; + IsPacked := fIsPacked; + fAlignSize := 1; + + If IdentSym = sOpenBracket Then + Begin + GetSym; + Expect([sIdent]); + + Parent := TRutisStructType(GetDeclaration(IdentStr)); + If not (Parent is TRutisStructType) Then + Begin + RaiseError('Struct-Type expected'); exit; + End; + Size := TRutisStructType(Parent).Size; + fAlignSize := TRutisStructType(Parent).fAlignSize; + //IsPacked := TRutisStructType(AParent).IsPacked; + + SetLength(StructTypes, Length(TRutisStructType(Parent).StructTypes)); + For i := 0 To high(TRutisStructType(Parent).StructTypes) Do + Begin + StructTypes[i] := TRutisVarDecl.Create; + StructTypes[i].VarType := TRutisStructType(Parent).StructTypes[i].VarType; + StructTypes[i].Address := TRutisStructType(Parent).StructTypes[i].Address; + StructTypes[i].isConst := TRutisStructType(Parent).StructTypes[i].isConst; + StructTypes[i].Level := TRutisStructType(Parent).StructTypes[i].Level; + StructTypes[i].Name := TRutisStructType(Parent).StructTypes[i].Name; + End; + + GetSym; + Expect([sCloseBracket]); + GetSym; + End; + + While True Do + Begin + SetLength(VarNames, 0); + While True Do + Begin + Expect([sIdent]); + SetLength(VarNames, Length(VarNames) + 1); + VarNames[High(VarNames)] := IdentStr; + GetSym; + If IdentSym <> scomma Then Break; + GetSym; + End; + Expect([sDopDot]); + GetSym; + + VType := C_DeclTypeInline(); + If VType = nil Then exit; + + int := high(StructTypes); + SetLength(StructTypes, Length(StructTypes) + Length(VarNames)); + + If optArrangeFields and not IsPacked Then + Begin + RasterSize := Max(Min(VType.AlignSize, optArrangeSize), 1); + fAlignSize := max(AlignSize, RasterSize); + j := RasterSize - (Size mod RasterSize); + If j < RasterSize Then + Begin + //ScriptData.GenCode(_gen, j, 0, 0); + Size := Size + j; + End; + End; + For i := int + 1 To high(StructTypes) Do + Begin + StructTypes[i] := TRutisVarDecl.Create; + StructTypes[i].VarType := VType; + StructTypes[i].Address := Size; + StructTypes[i].Name := VarNames[i - int - 1]; + Size := Size + VType.Size; + End; + + //GetSym; + Expect([sSemiColon]); + GetSym; + If not (IdentSym in [sIdent, sSemiColon]) Then break; + End; + If optArrangeFields and not IsPacked Then + Begin + j := AlignSize - (Size mod AlignSize); + If j < AlignSize Then + Begin + //ScriptData.GenCode(_gen, j, 0, 0); + Size := Size + j; + End; + End; + + Expect([sEnd]); + GetSym; + Expect([sSemiColon]); + GetSym; + End; + exit; + End; + + If IdentSym = sProcedure Then + Begin + GetSym; + RaiseError(ERR_NOT_IMPLEMENTED_YET); + exit; + End; + + // No record type so get "normal" type + + C_DeclTypeInline(TypeName); + Expect([sSemiColon]); + GetSym; +End; + +Procedure TRutisCompilerDelphi.C_DeclTypes; +Begin + While IdentSym = sIdent Do + Begin + C_DeclType; + End; +End; + +Procedure TRutisCompilerDelphi.C_DeclVars; +Var + i, j : Integer; + VarDecl : TRutisVarDecl; + VType : TRutisTypeDecl; + VarNames : Array Of AnsiString; + RasterSize : Byte; +Begin + While True Do + Begin + SetLength(VarNames, 0); + While True Do + Begin + Expect([sIdent]); + + If CheckRedefinition(IdentStr) Then + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + for I := 0 to high(VarNames) do + If VarNames[i] = IdentStr then + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + + SetLength(VarNames, Length(VarNames) + 1); + VarNames[High(VarNames)] := IdentStr; + + GetSym; + If IdentSym <> scomma Then Break; + GetSym; + End; + Expect([sDopDot]); + GetSym; + + VType := C_DeclTypeInline(); + + If VType = nil Then exit; + + For i := 0 To high(VarNames) Do + Begin + VarDecl := TRutisVarDecl.Create; + ScriptData.AddDeclaration(VarDecl, CurrentNamespace); + + If optArrangeFields Then + Begin + RasterSize := Max(Min(VType.AlignSize, optArrangeSize), 1); + j := RasterSize - (StackVarPos mod RasterSize); + If j < RasterSize Then + Begin + //ScriptData.GenCode(_gen, j, 0, 0); + StackVarPos := StackVarPos + j; + End; + End; + + VarDecl.Name := VarNames[i]; + VarDecl.IsConst := False; + VarDecl.VarType := VType; + VarDecl.Level := fCompilerLevel; + VarDecl.Address := StackVarPos; + //ScriptData.GenCode(_gen, VType.Size, 0, 0); + StackVarPos := StackVarPos + VType.Size; + End; + + //GetSym; + Expect([sSemiColon]); + While IdentSym = sSemiColon Do GetSym; + + If not (IdentSym in [sIdent, sSemiColon]) Then break; + End; +End; + +Procedure TRutisCompilerDelphi.C_DeclParams; +Var + i : Integer; + VarDecl : TRutisVarDecl; + VType : TRutisTypeDecl; + VarNames : Array Of AnsiString; +Begin + If IdentSym in [sSemiColon, sDopDot] Then exit; + + Expect([sOpenBracket]); + GetSym; + If IdentSym = sCloseBracket Then + Begin + GetSym; + exit; + End; + + While True Do + Begin + SetLength(VarNames, 0); + While True Do + Begin + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + Begin + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + exit; + End; + SetLength(VarNames, Length(VarNames) + 1); + VarNames[High(VarNames)] := IdentStr; + GetSym; + If IdentSym <> scomma Then Break; + GetSym; + End; + Expect([sDopDot]); + GetSym; + + VType := C_DeclTypeInline(); + + If VType = nil Then exit; + + For i := 0 To high(VarNames) Do + Begin + VarDecl := TRutisVarDecl.Create; + ScriptData.AddDeclaration(VarDecl, CurrentNamespace); + + VarDecl.Name := VarNames[i]; + VarDecl.IsConst := False; + VarDecl.VarType := VType; + VarDecl.Level := fCompilerLevel; + End; + + If IdentSym <> sSemiColon Then break; + While IdentSym = sSemiColon Do GetSym; + //GetSym; + End; + + Expect([sCloseBracket]); + GetSym; +End; + +Procedure TRutisCompilerDelphi.C_DeclConsts; +Var + VarDecl : TRutisVarDecl; + VarType : TRutisTypeDecl; + signum : Shortint; + //Str : PAnsiString; +Begin + While True Do + Begin + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + + VarDecl := TRutisVarDecl.Create; + ScriptData.AddDeclaration(VarDecl, CurrentNamespace); + + VarDecl.Name := IdentStr; + VarDecl.IsConst := True; + VarDecl.Level := 0; + VarDecl.Address := ScriptData.Ressources.Top; + + GetSym; + + VarType := nil; + If IdentSym = sDopDot Then + Begin + GetSym; + Expect([sIdent]); + + VarType := C_DeclTypeInline; + If VarType = nil Then + RaiseError(ERR_TYPE_EXPECTED); + End; + + Expect([sEqual]); + GetSym; + + If IdentSym = sMinus Then + Begin + GetSym; + signum := -1; + End + Else + signum := 1; + + If not (IdentSym in [sInteger..sString, sTrue, sFalse]) Then exit; + + Case IdentSym Of + sString : + Begin + If length(IdentStr) = 1 Then + Begin + // Save Ressource + ScriptData.Ressources.PushByte(Byte(IdentStr[1])); + VarDecl.ConstVal := IdentStr[1]; + // Get Ressource-Type + If VarType <> nil Then + Begin + If VarType.Size <> 1 Then + RaiseError(ERR_INCOMPATIBLE_TYPES, [VarType.Name, Owner.decl_AChar.Name]); + VarDecl.VarType := VarType; + End + Else + VarDecl.VarType := TRutisTypeDecl(Owner.decl_AChar); + End + Else + Begin + // Save Ressource + VarDecl.Address := ScriptData.Ressources.Top + 4; + IdentStr := IdentStr; + ScriptData.Ressources.PushAStringData(IdentStr); + VarDecl.ConstVal := IdentStr; + // Get Ressource-Type + If VarType <> nil Then + Begin + //If VarType.Size <> 4 then + RaiseError(ERR_INCOMPATIBLE_TYPES, [VarType.Name, Owner.decl_AString.Name]); + End + Else + VarDecl.VarType := TRutisTypeDecl(Owner.decl_AString); + End; + If (VarDecl.VarType = nil) or + (not (VarDecl.VarType is TRutisTypeDecl)) Then + Begin + RaiseError(ERR_NOT_AVAILABLE); + exit; + End; + End; + sInteger : + Begin + // Save Ressource + IdentNum := signum * IdentNum; + + VarDecl.ConstVal := IdentNum; + // Get Ressource-Type + If VarType <> nil Then + Begin + VarDecl.VarType := VarType; + If VarType.InternalType = intByte Then + Begin + If (IdentNum < 0) or (IdentNum >= 256) Then + RaiseError('Value must be between 0 and 255'); + ScriptData.Ressources.PushByte(IdentNum); + End + Else + If VarType.InternalType = intShortInt Then + Begin + If (IdentNum <= -128) or (IdentNum >= 128) Then + RaiseError('Value must be between -127 and 127'); + ScriptData.Ressources.PushShortInt(IdentNum); + End + Else + If VarType.InternalType = intWord Then + Begin + If (IdentNum < 0) or (IdentNum >= 65536) Then + RaiseError('Value must be between 0 and 65535'); + ScriptData.Ressources.PushWord(IdentNum); + End + Else + If VarType.InternalType = intSmallint Then + Begin + If (IdentNum <= -32768) or (IdentNum >= 32768) Then + RaiseError('Value must be between -32767 and 32767'); + ScriptData.Ressources.PushSmallint(IdentNum); + End + Else + If VarType.InternalType = intCardinal Then + ScriptData.Ressources.PushCardinal(IdentNum) + Else + If VarType.InternalType = intInteger Then + ScriptData.Ressources.PushInteger(IdentNum) + Else + RaiseError(ERR_INCOMPATIBLE_TYPES, [VarType.Name, Owner.decl_Integer.Name]); + End + Else + Begin + ScriptData.Ressources.PushCardinal(Cardinal(IdentNum)); + VarDecl.VarType := Owner.decl_Integer; + End; + End; + sFloat : + Begin + // Save Ressource + IdentNum := signum * IdentNum; + VarDecl.ConstVal := IdentNum; + // Get Ressource-Type + If VarType <> nil Then + Begin + VarDecl.VarType := VarType; + If VarType.InternalType = intSingle Then + ScriptData.Ressources.PushSingle(IdentNum) + Else + If VarType.InternalType = intDouble Then + ScriptData.Ressources.PushDouble(IdentNum) + Else + If VarType.InternalType = intExtended Then + ScriptData.Ressources.PushExtended(IdentNum) + Else + RaiseError(ERR_INCOMPATIBLE_TYPES, [VarType.Name, Owner.decl_Integer.Name]); + End + Else + Begin + ScriptData.Ressources.PushSingle(IdentNum); + VarDecl.VarType := Owner.decl_Single; + End; + End; + sTrue, sFalse : + Begin + // Save Ressource + VarDecl.ConstVal := Boolean(IdentSym = sTrue); + ScriptData.Ressources.PushByte(Byte(IdentSym = sTrue)); + // Get Ressource-Type + VarDecl.VarType := Owner.decl_Boolean; + If VarType <> nil Then + Begin + If VarType.Size <> 1 Then + RaiseError(ERR_INCOMPATIBLE_TYPES, [VarType.Name, VarDecl.VarType.Name]); + VarDecl.VarType := VarType; + End; + End; + Else + RaiseError(ERR_NOT_AVAILABLE_C_TYPE); + exit; + End; + + {!! Arrange Res-Fields} + while ScriptData.Ressources.Top mod 4 <> 0 do + ScriptData.Ressources.PushByte(0); + + GetSym; + Expect([sSemiColon]); + GetSym; + While IdentSym = sSemiColon Do GetSym; + + If not (IdentSym = sIdent) Then break; + End; +End; + +Procedure TRutisCompilerDelphi.C_DeclMethod; +Var + bool : Boolean; + MethodDecl : TRutisMethodType; + DllMethodDecl : TRutisDllMethodType; + MethodVar : TRutisVarDecl; + I : Integer; + + Function GetMethodParams : Boolean; + Var + i : Integer; + isVar : Boolean; + VType : TRutisTypeDecl; + VarNames : Array Of AnsiString; + Begin + Result := False; + If IdentSym <> sOpenBracket Then + Begin + Result := True; + MethodDecl.ParamsSize := 0; + exit; + End; + GetSym; + + While True Do + Begin + isVar := True; + If IdentSym = sVar Then + Begin + isVar := True; + GetSym; + End; + SetLength(VarNames, 0); + While True Do + Begin + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + Begin + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + exit; + End; + SetLength(VarNames, Length(VarNames) + 1); + VarNames[High(VarNames)] := IdentStr; + GetSym; + If IdentSym <> scomma Then Break; + GetSym; + End; + Expect([sDopDot]); + GetSym; + + VType := C_DeclTypeInline(); + + If VType = nil Then exit; + + For i := 0 To high(VarNames) Do + Begin + SetLength(MethodDecl.Params, Length(MethodDecl.Params) + 1); + With MethodDecl.Params[high(MethodDecl.Params)] Do + Begin + TypeData := VType; + isVarParam := isVar; + End; + MethodDecl.ParamsSize := MethodDecl.ParamsSize + VType.Size; + End; + + If IdentSym <> sSemiColon Then break; + While IdentSym = sSemiColon Do GetSym; + End; + + Expect([sCloseBracket]); + GetSym; + Result := True; + End; + +Begin + If not (IdentSym in [sProcedure, sFunction]) Then exit; + + bool := IdentSym = sFunction; + GetSym; + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + Begin + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + exit; + End; + + MethodVar := TRutisVarDecl.Create; + ScriptData.AddDeclaration(MethodVar, CurrentNamespace); + + MethodVar.Name := IdentStr; + MethodVar.IsConst := True; + MethodVar.Level := 0; + MethodVar.VarType := TRutisMethodType.Create; + MethodDecl := TRutisMethodType(MethodVar.VarType); + + MethodVar.Address := ScriptData.Ressources.Top; + ScriptData.Ressources.PushCardinal(Cardinal(high(ScriptData.Code) + 1)); + + Try + With MethodDecl Do + Begin + ParamsSize := 0; + IsFunction := bool; + If IsFunction Then + Name := 'function' + Else + Name := 'procedure'; + + GetSym; + + If not GetMethodParams Then + Begin + MethodDecl.Free; exit; + End; + + If IsFunction Then + Begin + Expect([sDopDot]); + GetSym; + + MethodResult.TypeData := TRutisTypeDecl(GetDeclaration(IdentStr)); + If (MethodResult.TypeData = nil) or (not (MethodResult.TypeData is TRutisTypeDecl)) Then + Begin + RaiseError(ERR_TYPE_EXPECTED); + MethodDecl.Free; + exit; + End; + GetSym; + End; + + Expect([sSemiColon]); + GetSym; + End; + + Except + MethodDecl.Free; + Raise; + End; + + //function MeineFunc(...); external 'MeineDll.dll' name 'MeinFunc'; + If IdentSym = sExternal Then + Begin + GetSym; + DllMethodDecl := TRutisDllMethodType.Create; + DllMethodDecl.Method_Name := MethodDecl.Method_Name; + DllMethodDecl.Description := MethodDecl.Description; + DllMethodDecl.Params := MethodDecl.Params; + DllMethodDecl.ParamsSize := MethodDecl.ParamsSize; + DllMethodDecl.IsFunction := MethodDecl.IsFunction; + DllMethodDecl.MethodResult.TypeData := MethodDecl.MethodResult.TypeData; + DllMethodDecl.Declarations := MethodDecl.Declarations; + DllMethodDecl.Size := MethodDecl.Size; + DllMethodDecl.Name := MethodDecl.Name; + MethodVar.VarType := DllMethodDecl; + MethodDecl.Free; + ScriptData.AddDeclaration(DllMethodDecl, CurrentNamespace); + + If IdentSym = sIdent Then + Begin + RaiseError('DLL-Name and Method-Name can not be Variables or Constants. Only Strings with '' '' are usable'); exit; + End; + Expect([sString]); + DllMethodDecl.DllName := IdentStr; + GetSym; + + Expect([sIdent]); + If IdentStr <> 'NAME' Then + Begin + RaiseError(ERR_EXPECTED_FOUND, ['name', IdentStr]); + exit; + End; + GetSym; + + If IdentSym = sIdent Then + Begin + RaiseError('DLL-Name and Method-Name can not be Variables or Constants. Only Strings with '' '' are usable'); exit; + End; + Expect([sString]); + DllMethodDecl.ProcName := IdentStr; + GetSym; + + Expect([sSemiColon]); + GetSym; + + For I := 0 To high(DllMethodDecl.Params) Do + If DllMethodDecl.Params[i].isVarParam Then + Begin + DllMethodDecl.ParamsSize := DllMethodDecl.ParamsSize - + DllMethodDecl.Params[i].TypeData.Size + 4; + DllMethodDecl.Params[i].TypeData := + GetPointerType(DllMethodDecl.Params[i].TypeData); + //DllMethodDecl.Params[i].isVarParam := false; + End; + + exit; + End; + + ScriptData.AddDeclaration(MethodDecl, CurrentNamespace); + exit; +End; + +Function TRutisCompilerDelphi.C_DeclarationSeq : Boolean; +Begin + Result := False; + + If IdentSym = sType Then + Begin + Result := True; + GetSym; + C_DeclTypes; + exit; + End; + + If IdentSym = sVar Then + Begin + Result := True; + GetSym; + C_DeclVars; + exit; + End; + + If (IdentSym in [sProcedure, sFunction]) and fCompilingDefines Then + Begin + Result := True; + C_DeclMethod; + exit; + End; + + If IdentSym = sConst Then + Begin + Result := True; + GetSym; + C_DeclConsts; + exit; + End; +End; + +Procedure TRutisCompilerDelphi.C_Declarations; +Begin + Repeat Until not C_DeclarationSeq; +End; + +//============================================================================== + +Function TRutisCompilerDelphi.C_Method : Boolean; +Var + i, j : Integer; + bool : Boolean; + MethodDecl : TRutisMethodType; + MethodVar : TRutisVarDecl; + VarDecl : TRutisVarDecl; + OldStackVarPos : Integer; + OldNamespace : AnsiString; + Namespace : TRutisNamespace; + MethodInitAddr : Integer; + +Begin + Result := False; + If not (IdentSym in [sProcedure, sFunction]) Then exit; + + bool := IdentSym = sFunction; + GetSym; + Expect([sIdent]); + If CheckRedefinition(IdentStr) Then + Begin + RaiseError(ERR_INDENT_REDEFINED, [IdentStr]); + exit; + End; + + //{!!}Owner.OnError('-> C_Method ' + IdentStr, etHint); + + If fCompilerLevel > 0 Then + Begin + ScriptData.GenCode(_jmp, 0, 0, 0); + MethodInitAddr := high(ScriptData.Code); + End + Else + MethodInitAddr := -1; + + Inc(fCompilerLevel); + + MethodVar := TRutisVarDecl.Create; + ScriptData.AddDeclaration(MethodVar, CurrentNamespace); + + MethodVar.Name := IdentStr; + MethodVar.IsConst := True; + MethodVar.Level := fCompilerLevel; + MethodVar.VarType := TRutisMethodType.Create; + MethodVar.Address := ScriptData.Ressources.Top; + ScriptData.Ressources.PushCardinal(Cardinal(high(ScriptData.Code) + 1)); + + MethodDecl := TRutisMethodType(MethodVar.VarType); + + // Create Namespace... + OldNamespace := CurrentNamespace; + CurrentNamespace := UpperCase(CurrentNamespace + '.' + MethodVar.Name); + Namespace := TRutisNamespace.Create; + Namespace.Name := CurrentNamespace; + Namespace.CodeFile := CurrentUnit; + Namespace.CodeStart := length(ScriptData.Code); + + SetLength(ScriptData.Namespaces, length(ScriptData.Namespaces) + 1); + ScriptData.Namespaces[high(ScriptData.Namespaces)] := Namespace; + // ... and add it to the Current-Uses List + SetLength(UnitNamespaces, length(UnitNamespaces) + 1); + UnitNamespaces[high(UnitNamespaces)] := CurrentNamespace; + + OldStackVarPos := StackVarPos; + StackVarPos := 0; + VarDecl := nil; + + Try + With MethodDecl Do + Begin + ParamsSize := 0; + IsFunction := bool; + MethodResult.TypeData := nil; + If IsFunction Then + Name := 'function' + Else + Name := 'procedure'; + + GetSym; + + If IsFunction Then + Begin + VarDecl := TRutisVarDecl.Create; + ScriptData.AddDeclaration(VarDecl, Namespace.Name); + With VarDecl Do + Begin + Name := 'RESULT'; + IsConst := False; + Address := StackVarPos; + Level := fCompilerLevel; + End; + Inc(StackVarPos); + End; + + If IdentSym = sOpenBracket Then + C_DeclParams; + + If IsFunction Then + Begin + Expect([sDopDot]); + + GetSym; + + MethodResult.TypeData := TRutisTypeDecl(GetDeclaration(IdentStr)); + VarDecl.VarType := MethodResult.TypeData; + If (VarDecl.VarType = nil) or + (not (VarDecl.VarType is TRutisTypeDecl)) Then + Begin + RaiseError(ERR_TYPE_EXPECTED); + MethodDecl.Free; + exit; + End; + GetSym; + End; + + //Get Parameters + If IsFunction Then + i := 1 + Else + i := 0; + ParamsSize := 0; + SetLength(Params, 0); + For i := i To high(Namespace.Declarations) Do + If Namespace.Declarations[i] is TRutisVarDecl Then + Begin + ParamsSize := ParamsSize + TRutisVarDecl(Namespace.Declarations[i]).VarType.Size; + SetLength(Params, length(Params) + 1); + Params[high(Params)].TypeData := TRutisVarDecl(Namespace.Declarations[i]).VarType; + End; + + //Get Parameter-Addresses + j := -ParamsSize; + If IsFunction Then + j := j - MethodResult.TypeData.Size; + For i := 0 To high(Namespace.Declarations) Do + If Namespace.Declarations[i] is TRutisVarDecl Then + Begin + TRutisVarDecl(Namespace.Declarations[i]).Address := j; + j := j + TRutisVarDecl(Namespace.Declarations[i]).VarType.Size; + End; + StackVarPos := 0; + + Expect([sSemiColon]); + GetSym; + End; + + Repeat + bool := C_DeclarationSeq or C_Method; + Until not bool; + + Expect([sBegin]); + GetSym; + + ExitParamsSize := MethodDecl.ParamsSize; + // MethodenfCode ====== + + If StackVarPos > 0 Then + Begin + ScriptData.GenCode(_gen, StackVarPos, 0, 0); + StackVarPos := 0; + End; + + C_StatementSequence; + + ScriptData.GenCode(_ret, MethodDecl.ParamsSize, 0, 0); + + If MethodInitAddr >= 0 Then + ScriptData.Code[MethodInitAddr].P1 := high(ScriptData.Code) + 1; + + Expect([sEnd]); + GetSym; + Expect([sSemiColon]); + GetSym; + + // Reset Namespace + Namespace.CodeEnd := high(ScriptData.Code); + SetLength(UnitNamespaces, length(UnitNamespaces) - 1); + CurrentNamespace := OldNamespace; + + //Reset StackVarPos and CurrentNamespace and decrement CompilerLevel + StackVarPos := OldStackVarPos; + Dec(fCompilerLevel); + + bool := False; + For i := 0 To ScriptData.DeclarationCount - 1 Do + If ScriptData.DeclarationList[i].ClassType = TRutisMethodType Then + With TRutisMethodType(ScriptData.DeclarationList[i]) Do + Begin + If (IsFunction <> MethodDecl.IsFunction) Then Continue; + If (length(Params) <> length(MethodDecl.Params)) Then Continue; + If (ParamsSize <> MethodDecl.ParamsSize) Then Continue; + If (MethodResult.TypeData <> MethodDecl.MethodResult.TypeData) Then Continue; + bool := True; + For j := 0 To high(Params) Do + If Params[j].TypeData <> MethodDecl.Params[j].TypeData Then + Begin + bool := False; + Break; + End; + If not bool Then Continue; + Break; + End; + If bool Then + Begin + MethodDecl.Free; + MethodVar.VarType := TRutisMethodType(ScriptData.DeclarationList[i]); + End + Else + ScriptData.AddDeclaration(MethodDecl, '$SYSTEM'); + + Except + MethodDecl.Free; + Raise; + End; + + //{!!}Owner.OnError('<- C_Method ' + MethodVar.Name, etHint); + Result := True; +End; + +Procedure TRutisCompilerDelphi.C_Implementation; +Begin + Repeat + C_Declarations; + Until not C_Method; +End; + +//============================================================================== + +Function TRutisCompilerDelphi.C_AnalyzeIdent(IsExpression : Boolean; WantType : TRutisIntType; Var Inf : TAnalyzeIdentInfo) : TIdentType; +Var + HadPointer : Boolean; + HadAt : Boolean; + ExcludeList : Array Of TRutisDecl; + + Procedure AnalyzeVar; + Var id : Integer; + Begin //AnalyzeVar + With Inf Do + Begin + //=========================================== + // Copy-Types + //=========================================== + While (Inf.TypeData is TRutisTypeCopy) Do + Begin + Inf.TypeData := TRutisTypeCopy(Inf.TypeData).CopyType; + End; + + //=========================================== + // Analyze Arrays + //=========================================== + If (Inf.TypeData is TRutisArrayType) and (IdentSym = sOpenBracketR) Then + Begin + GetSym; + + If HadPointer Then + Begin + If (Inf.Adr <> 0) Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, -1, 4); + End + Else + ScriptData.GenCode(_lod, Inf.Adr, Inf.Lvl, 4); + + C_Expression(Owner.decl_Integer); + + ScriptData.GenCode(_gen4, TRutisArrayType(Inf.TypeData).ArrayType.Size, 0, 0); + ScriptData.GenCodeV(_mult, intInteger, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + If optArrayRangeCheck Then + ScriptData.GenCodeV(_CPtr, 0, 0, 0); + + HadPointer := True; + Inf.Adr := 0; + Inf.Lvl := -1; + Inf.TypeData := TRutisArrayType(Inf.TypeData).ArrayType; + Inf.InternalType := TypeData.InternalType; + + Expect([sCloseBracketR]); + GetSym; + Result := itPVar; + AnalyzeVar; + exit; + End; + + //=========================================== + // Analyze Strings with Index + //=========================================== + Inf.InternalType := TypeData.InternalType; + If (Inf.InternalType = intAString) and (IdentSym = sOpenBracketR) Then + Begin + GetSym; + + //PChar(Pointer(PCardinal(PPointer(fLastAdress)^)^ + 0))^ + + If Result = itConst Then + Begin + ScriptData.GenCode(_lodr, Inf.Adr, 1, 0); + ScriptData.GenCode(_at, 0, 0, 0); + ScriptData.GenCode(_lodp, -4, -1, 4); + //ScriptData.GenCode(_lodp, -4, -1, 4); + End + Else + Begin + If HadPointer Then + Begin + If (Inf.Adr <> 0) Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, -1, 4); + End + Else + ScriptData.GenCode(_lod, Inf.Adr, Inf.Lvl, 4); + //ScriptData.GenCode(_lodp, -4, -1, 4); + End; + + C_Expression(Owner.decl_Integer); + + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCodeV(_Sub, intInteger, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + + HadPointer := True; + Inf.Adr := 0; + Inf.Lvl := -1; + TypeData := Owner.decl_AChar; + Inf.InternalType := TypeData.InternalType; + + Expect([sCloseBracketR]); + GetSym; + Result := itPVar; + //AnalyzeVar; + //exit; + End; + + If (Inf.InternalType = intWString) and (IdentSym = sOpenBracketR) Then + Begin + GetSym; + If Result = itConst Then + Begin + ScriptData.GenCode(_lodr, Inf.Adr, 1, 0); + ScriptData.GenCode(_at, 0, 0, 0); + ScriptData.GenCode(_lodp, -4, -1, 4); + //ScriptData.GenCode(_lodp, -4, -1, 4); + End + Else + Begin + If HadPointer Then + Begin + If (Inf.Adr <> 0) Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, -1, 4); + End + Else + ScriptData.GenCode(_lod, Inf.Adr, Inf.Lvl, 4); + //ScriptData.GenCode(_lodp, -4, -1, 4); + End; + + C_Expression(Owner.decl_Integer); + + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCodeV(_Sub, intInteger, 0, 0); + ScriptData.GenCode(_gen4, 2, 0, 0); + ScriptData.GenCodeV(_Mult, intInteger, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + + HadPointer := True; + Inf.Adr := 0; + Inf.Lvl := -1; + TypeData := Owner.decl_WChar; + Inf.InternalType := TypeData.InternalType; + + Expect([sCloseBracketR]); + GetSym; + Result := itPVar; + //AnalyzeVar; + //exit; + End; + + If IdentSym = sOpenBracketR Then + Begin + RaiseError(ERR_NEEDED_FOUND, ['Array or AnsiString', RutisVarTypeTOString[TypeData.InternalType]]); exit; + End; + + //=========================================== + // Analyze Pointers + //=========================================== + If (TypeData is TRutisPointerType) Then + If IdentSym in [sHook, sDot] Then + Begin + If IdentSym = sHook Then GetSym; + + If HadPointer Then + Begin + If Inf.Adr <> 0 Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, Inf.Lvl, 4); + End + Else + ScriptData.GenCode(_lod, Inf.Adr, Inf.Lvl, 4); + + Inf.Adr := 0; + Inf.Lvl := -1; + + HadPointer := True; + Result := itPVar; + + TypeData := TRutisPointerType(TypeData).PointerType; + AnalyzeVar; + exit; + End; + If IdentSym = sHook Then + Begin + RaiseError(ERR_NEEDED_FOUND, ['Pointer', RutisVarTypeTOString[TypeData.InternalType]]); exit; + End; + + //=========================================== + // Analyze Classes + //=========================================== + If (TypeData is TRutisClassType) Then + If IdentSym = sDot Then + Begin + If HadPointer Then + Begin + If Inf.Adr <> 0 Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, Inf.Lvl, 4); + End + Else + ScriptData.GenCode(_lod, Inf.Adr, Inf.Lvl, 4); + + Inf.Adr := 0; + Inf.Lvl := -1; + + HadPointer := True; + Result := itPVar; + + TypeData := TRutisClassType(TypeData).ClassStruct; + + PushScanner; + GetSym; + If (IdentSym = sIdent) and + ((IdentStr = 'CLASSNAME') or + (IdentStr = 'INSTANCESIZE') or + (IdentStr = 'CLASSPARENT')) Then + Begin + TypeData := TRutisStructType(TypeData).StructTypes[0].VarType; + ScriptData.GenCode(_lodp, -4, Inf.Lvl, 4); + TypeData := TRutisPointerType(TypeData).PointerType; + + id := TRutisStructType(TypeData).VarID(IdentStr); + Inf.Adr := Inf.Adr + TRutisStructType(TypeData).StructTypes[id].Address; + TypeData := TRutisStructType(TypeData).StructTypes[id].VarType; + + If (IdentStr = 'CLASSNAME') Then + Begin + If Inf.Adr <> 0 Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + ScriptData.GenCode(_lodp, -4, Inf.Lvl, 4); + Inf.Adr := 0; + TypeData := TRutisPointerType(TypeData).PointerType; + End; + + GetSym; + End + Else + PopScanner; + + AnalyzeVar; + exit; + End; + If IdentSym = sHook Then + Begin + RaiseError(ERR_NEEDED_FOUND, ['Pointer', RutisVarTypeTOString[TypeData.InternalType]]); exit; + End; + + + //=========================================== + // Analyze Record-Structures + //=========================================== + If (TypeData is TRutisStructType) and (IdentSym = sDot) Then + Begin + GetSym; + Expect([sIdent]); + + id := TRutisStructType(TypeData).VarID(IdentStr); + If id = -1 Then + Begin + RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); exit; + End; + GetSym; + + Inf.Adr := Inf.Adr + TRutisStructType(TypeData).StructTypes[id].Address; + TypeData := TRutisStructType(TypeData).StructTypes[id].VarType; + + AnalyzeVar; + exit; + End; + If IdentSym = sDot Then + Begin + RaiseError(ERR_NEEDED_FOUND, ['Record', RutisVarTypeTOString[TypeData.InternalType]]); exit; + End; + + If HadPointer Then + Begin + If (Inf.Adr <> 0) Then + Begin + ScriptData.GenCode(_gen4, Inf.Adr, 0, 0); + ScriptData.GenCodeV(_add, intInteger, 0, 0); + End; + Inf.Adr := -4; + Inf.Lvl := -1; + Result := itPVar; + exit; + End; + + Inf.InternalType := TypeData.InternalType; + End; + End; + + Procedure CallVarMethod; + Begin + GenLoadSaveCode(Inf.IdentType, Inf.Adr, Inf.Lvl, Inf.TypeData.Size, True); + + Result := itMethod; + Inf.IdentType := Result; + {If isFunction and IsExpression Then + Begin + Inf.Lvl := -1; + Inf.Adr := 0; + Result := itFixVal; +//AnalyzeVar; + End;} + + ScriptData.GenCode(_call, -1, 0, 0); + End; + + Procedure CallExtMethod; + Var + TempType : TRutisExtMethodType; + i : Integer; + Begin + TempType := TRutisExtMethodType(Inf.TypeData); + With TempType Do + Begin + If IsExpression and not IsFunction Then + Begin + RaiseError(ERR_EXPECTED_FOUND, ['Function', 'Procedure']); exit; + End; + If IsFunction Then + Begin + If MethodResult.TypeData = nil Then + Begin + MethodResult.TypeData := TRutisTypeDecl(GetDeclaration(MethodResult.Name)); + If (MethodResult.TypeData = nil) Then + RaiseError(ERR_UNKNOWN_TYPE, [MethodResult.Name]); + If not (MethodResult.TypeData is TRutisTypeDecl) Then + RaiseError(ERR_TYPE_EXPECTED); + MethodResult.Size := MethodResult.TypeData.Size; + MethodResult.InternalType := MethodResult.TypeData.InternalType; + End; + Inf.TypeData := MethodResult.TypeData; + ScriptData.GenCode(_gen, Inf.TypeData.Size, 0, 0); + End; + + ParamsSize := 0; + If length(Params) > 0 Then + Begin + Expect([sOpenBracket]); + For i := 0 To high(Params) Do + Begin + If Params[i].TypeData = nil Then + Begin + Params[i].TypeData := TRutisTypeDecl(GetDeclaration(Params[i].Name)); + If (Params[i].TypeData = nil) Then + RaiseError(ERR_UNKNOWN_TYPE, [Params[i].Name]); + If not (Params[i].TypeData is TRutisTypeDecl) Then + RaiseError(ERR_TYPE_EXPECTED); + End; + Params[i].Size := Params[i].TypeData.Size; + Params[i].InternalType := Params[i].TypeData.InternalType; + ParamsSize := ParamsSize + Params[i].TypeData.Size; + + If Params[i].isVarParam Then + IdentSym := sAt + Else + GetSym; + C_Expression(Params[i].TypeData); + If (i < high(Params)) Then + Begin + If IdentSym = sCloseBracket Then + Begin + RaiseError(ERR_NOT_ENOUGH_PARAMETERS); exit; + End; + Expect([sComma]); + End; + End; + If IdentSym = sComma Then + Begin + RaiseError(ERR_TOO_MANY_PARAMETERS); + exit; + End; + Expect([sCloseBracket]); + GetSym; + End + Else + If IdentSym = sOpenBracket Then + Begin + GetSym; + Expect([sCloseBracket]); + End; + + If MethodTableID < 0 Then + Begin + SetLength(ScriptData.MethodTable, Length(ScriptData.MethodTable) + 1); + ScriptData.MethodTable[high(ScriptData.MethodTable)] := TempType; + MethodTableID := high(ScriptData.MethodTable); + End; + + If not IsExpression and IsFunction Then + ScriptData.GenCodeV(_ext, MethodTableID, 1, 0) + Else + ScriptData.GenCodeV(_ext, MethodTableID, 0, 0); + + Result := itMethod; + If isFunction and IsExpression Then + Begin + Inf.Lvl := -1; + Inf.Adr := 0; + Result := itFixVal; + //AnalyzeVar; + End; + + Inf.IdentType := Result; + exit; + End; + End; + + Procedure CallRutisMethod; + Var + TempType : TRutisMethodType; + i : Integer; + Begin + TempType := TRutisMethodType(Inf.TypeData); + With TempType Do + Begin + If IsExpression and not IsFunction Then + Begin + RaiseError(ERR_EXPECTED_FOUND, ['Function', 'Procedure']); exit; + End; + If IsFunction Then + Begin + Inf.TypeData := MethodResult.TypeData; + ScriptData.GenCode(_gen, Inf.TypeData.Size, 0, 0); + End; + + If length(Params) > 0 Then + Begin + Expect([sOpenBracket]); + For i := 0 To high(Params) Do + Begin + GetSym; + C_Expression(Params[i].TypeData); + If (i < high(Params)) Then + Begin + If IdentSym = sCloseBracket Then + Begin + RaiseError(ERR_NOT_ENOUGH_PARAMETERS); exit; + End; + Expect([sComma]); + End; + End; + If IdentSym = sComma Then + Begin + RaiseError(ERR_TOO_MANY_PARAMETERS); + exit; + End; + Expect([sCloseBracket]); + GetSym; + End + Else + If IdentSym = sOpenBracket Then + Begin + GetSym; + Expect([sCloseBracket]); + End; + + //Prozeduraufruf +// ScriptData.GenCode(_lodr, Inf.Adr, 4, 0); +// ScriptData.GenCode(_call, -1, Inf.Lvl, 0); + ScriptData.GenCode(_call, ScriptData.Ressources.GetCardinal(Inf.Adr)^, Inf.Lvl, 0); + + If not IsExpression and IsFunction Then + ScriptData.GenCode(_pupo, -Inf.TypeData.Size, 0, 0); + + Result := itMethod; + If isFunction and IsExpression Then + Begin + Inf.Lvl := -1; + Inf.Adr := 0; + Result := itFixVal; + //AnalyzeVar; + End; + + Inf.IdentType := Result; + exit; + End; + End; + +Var + CastInf : TAnalyzeIdentInfo; + Decl : TRutisDecl; +Begin + Result := itError; + //================================================================== + Inf.TypeData := nil; + Inf.VarDecl := nil; + Inf.Adr := 0; + Inf.Lvl := 0; + Inf.IdentType := Result; + HadPointer := False; + HadAt := False; + + If IdentSym = sAt Then + Begin + HadAt := True; + GetSym; + End; + + Decl := GetDeclaration(IdentStr); + If Decl = nil Then + RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); + + If (Decl is TRutisTypeDecl) Then + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + +// C_Expression(nil); +// If not ExprResult.ConvertTo(TRutisTypeDecl(Decl), ScriptData) Then +// If ExprResult.Size <> TRutisTypeDecl(Decl).Size Then +// RaiseError(ERR_INCOMPATIBLE_TYPES, [TRutisTypeDecl(Decl).Name, ExprResult.Name]); +// Inf.TypeData := TRutisTypeDecl(Decl); +// Inf.Adr := -Inf.TypeData.Size; +// Inf.Lvl := 0; +// Inf.IdentType := itFixVal; + + Expect([sIdent]); + C_AnalyzeIdent(True, intNone, CastInf); + If not CastInf.TypeData.ConvertTo(TRutisTypeDecl(Decl), ScriptData) Then + If CastInf.TypeData.Size <> TRutisTypeDecl(Decl).Size Then + RaiseError(ERR_INCOMPATIBLE_TYPES, [TRutisTypeDecl(Decl).Name, CastInf.TypeData.Name]); + Inf := CastInf; + Inf.TypeData := TRutisTypeDecl(Decl); + + + Expect([sCloseBracket]); + End + Else + Begin + If not (Decl is TRutisVarDecl) Then + RaiseError(ERR_VAR_EXPECTED, [IdentStr]); + + Inf.VarDecl := TRutisVarDecl(Decl); + Inf.TypeData := Inf.VarDecl.VarType; + Inf.Adr := Inf.VarDecl.Address; + Inf.Lvl := Inf.VarDecl.Level; + Result := itVar; + End; + + // Get next symbol after Ident + GetSym; + + //================================================================== + //================================================================== + If HadAt Then + Begin + AnalyzeVar; + + If (Inf.VarDecl.isConst) Then + Begin + If not (Inf.TypeData is TRutisMethodType) Then + Begin + RaiseError(ERR_VAR_EXPECTED); exit; + End; + If (TRutisMethodType(Inf.TypeData).IsFunction) or (TRutisMethodType(Inf.TypeData).ParamsSize > 0) Then + Begin + RaiseError(ERR_ONLY_PARAMLESS_PROCS); exit; + End; + + Result := itConst; + ScriptData.GenCode(_lodr, Inf.Adr, 4, 0); + Inf.TypeData := Owner.decl_Method; + Result := itFixVal; + Inf.IdentType := Result; + Inf.InternalType := Inf.TypeData.InternalType; + exit; + End; + If not IsExpression Then + Begin + RaiseError(ERR_UNALLOWED_STATEMENT); exit; + End; + + Case Result Of + itVar : + Begin + //If Inf.Adr < 0 Then + // ScriptData.GenCode(_ptr, Inf.Adr - 3, Inf.Lvl, 1) + //Else + ScriptData.GenCode(_ptr, Inf.Adr, Inf.Lvl, 1); + End; + itPVar :; + itConst : + Begin + If (Inf.TypeData is TRutisMethodType) Then + ScriptData.GenCode(_lodr, Inf.Adr, 4, 0) + Else + Begin + ScriptData.GenCode(_lodr, Inf.Adr, 1, 0); + ScriptData.GenCode(_at, 0, 0, 0); + End; + End; + Else + RaiseError(ERR_POINTER_ONLY_FOR_VAR); exit; + End; + Inf.TypeData := Owner.decl_Pointer; + Result := itFixVal; + Inf.IdentType := Result; + Inf.InternalType := Inf.TypeData.InternalType; + + exit; + End; + + //================================================================== + //================================================================== + If (Inf.TypeData is TRutisMethodType) Then + Begin + If TRutisMethodType(Inf.TypeData).Overloaded Then + Begin + SetLength(ExcludeList, 0); + While True Do + Begin + PushCompilerState; + SetLength(ExcludeList, length(ExcludeList) + 1); + ExcludeList[high(ExcludeList)] := Inf.VarDecl; + Try + If (Inf.TypeData is TRutisExtMethodType) or + (Inf.TypeData is TRutisDllMethodType) Then + CallExtMethod + Else + CallRutisMethod; + Except + Inf.VarDecl := TRutisVarDecl(GetDeclaration(Inf.VarDecl.Name, ExcludeList)); + Inf.TypeData := Inf.VarDecl.VarType; + If Inf.VarDecl = nil Then + RaiseError(ERR_NO_OVERLOADED_FUNC); + PopCompilerState; + Continue; + End; + exit; + End; + End + Else + Begin + If (Inf.TypeData is TRutisExtMethodType) or + (Inf.TypeData is TRutisDllMethodType) Then + CallExtMethod + Else + CallRutisMethod; + exit; + End; + End; + //================================================================== + //================================================================== + + //If IdentPos >= 0 Then + Begin + Result := itVar; + If inf.VarDecl.isConst and not IsExpression Then + Begin + RaiseError(ERR_VAR_EXPECTED); exit; + End; + If inf.VarDecl.isConst Then + Begin + Result := itConst; + If inf.VarDecl.VarType.InternalType = intAString Then + Begin + ScriptData.GenCode(_rstr, Inf.Adr, 0, 0); + Result := itFixVal; + End; + End; + + AnalyzeVar; + + Inf.IdentType := Result; + Inf.InternalType := Inf.TypeData.InternalType; + + If (IdentSym <> sBecomes) and (Inf.InternalType = intMethod) Then + CallVarMethod; + + exit; + End; +End; + +procedure TRutisCompilerDelphi.C_Expression(WantType : TRutisTypeDecl); +Var + OldWantType : TRutisTypeDecl; + gotStr : Boolean; + // LastIntTypes : Array of TRutisIntType; + + Procedure Term; + Var + FactorType : TRutisTypeDecl; + + Procedure Factor; + Var + Inf : TAnalyzeIdentInfo; + bool : Boolean; + //PAnsiStr : PAnsiString; + ConvPos, i : Integer; + Decl : TRutisDecl; + Begin (*Factor*) + FactorType := nil; + ConvPos := high(ScriptData.Code); + Case IdentSym Of + sIdent, sAt : + Begin + C_AnalyzeIdent(True, WantType.InternalType, Inf); + FactorType := Inf.TypeData; + + If FactorType = nil Then + RaiseError(ERR_VAR_EXPECTED); + + GenLoadSaveCode(Inf.IdentType, Inf.Adr, Inf.Lvl, FactorType.Size, True); + End; + sSizeOf : + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + Decl := GetDeclaration(IdentStr); + If Decl is TRutisTypeDecl Then + Begin + ScriptData.GenCode(_Gen4, TRutisTypeDecl(Decl).Size, 0, 0); + GetSym; + End + Else + Begin + i := length(ScriptData.Code); + C_AnalyzeIdent(False, intNone, Inf); + SetLength(ScriptData.Code, i); + ScriptData.GenCode(_Gen4, Inf.TypeData.Size, 0, 0); + End; + + FactorType := Owner.decl_Integer; + + Expect([sCloseBracket]); + GetSym; + End; + sLength, + sHigh : With Inf Do + Begin + bool := IdentSym = sHigh; + + FactorType := Owner.decl_Integer; + + GetSym; + Expect([sOpenBracket]); + GetSym; + + If IdentSym = sString Then + Begin + ScriptData.GenCode(_gen4, length(IdentStr), 0, 0); + If bool Then + Begin + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCodeV(_sub, intInteger, 0, 0); + End; + GetSym; + Expect([sCloseBracket]); + GetSym; + End + Else + Begin + Expect([sIdent]); + + //AllowedIdents := [vString, vArray]; + C_AnalyzeIdent(True, intNone, Inf); + Case Inf.IdentType Of + itVar : + Begin + If Inf.TypeData is TRutisArrayType Then + Begin + ScriptData.GenCode(_lod, Adr, Lvl, 4); + ScriptData.GenCode(_mems, 0, 0, 1); + //If (TRutisArrayType(Inf.TypeData).ArrayType.Size > 1) Then + //Begin + // ScriptData.GenCode(_gen4, TRutisArrayType(Inf.TypeData).ArrayType.Size, 0, 0); + // ScriptData.GenCodeV(_div, intInteger, 0, 0); + //End; + End + Else + Begin + case Inf.TypeData.InternalType of + intAString: + begin + ScriptData.GenCode(_lod, Adr, Lvl, 4); + ScriptData.GenCode(_GASL, 0, 0, 0); + end; + intWString: + begin + ScriptData.GenCode(_lod, Adr, Lvl, 4); + ScriptData.GenCode(_GWSL, 0, 0, 0); + end; + else + RaiseError(ERR_EXPECTED, ['AnsiString, WideString, Array']); + end; + End; + End; + itPVar : + Begin + If Inf.TypeData is TRutisArrayType Then + Begin + ScriptData.GenCode(_lodP, Adr, Lvl, 4); + ScriptData.GenCode(_mems, 0, 0, 1); + //If (TRutisArrayType(Inf.TypeData).ArrayType.Size > 1) Then + //Begin + // ScriptData.GenCode(_gen4, TRutisArrayType(Inf.TypeData).ArrayType.Size, 0, 0); + // ScriptData.GenCodeV(_div, intInteger, 0, 0); + //End; + End + Else + Begin + case Inf.TypeData.InternalType of + intAString: + begin + ScriptData.GenCode(_lodP, Adr, Lvl, 4); + ScriptData.GenCode(_GASL, 0, 0, 0); + end; + intWString: + begin + ScriptData.GenCode(_lodP, Adr, Lvl, 4); + ScriptData.GenCode(_GWSL, 0, 0, 0); + end; + else + RaiseError(ERR_EXPECTED, ['AnsiString, WideString, Array']); + end; + End; + End; + itConst : + Begin + { If VarInf^.VTyp = vString Then + Begin + ScriptData.GenCode(_lodr, Adr, 1, 0); + ScriptData.GenCode(_GASL, 0, 0, 0); + End + Else } + RaiseError(ERR_EXPECTED, ['AnsiString, WideString, Array']); + End; + itMethod : RaiseError(ERR_VAR_EXPECTED); + itError : RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); + End; + + If bool Then + Begin + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCodeV(_sub, intInteger, 0, 0); + End; + + Expect([sCloseBracket]); + GetSym; + End; + End; + sTrue, sFalse : + Begin + ScriptData.GenCode(_gen1, Integer(Boolean(IdentSym = sTrue)), 0, 0); + FactorType := Owner.decl_Boolean; + GetSym; + End; + sopAnd : + Begin + GetSym; + Factor; + If WantType = nil Then + RaiseError('ERROR - C_Expression - Term - Factor'); + ScriptData.GenCodeV(_And, WantType.Size, 0, 0); + End; + sopOr : + Begin + GetSym; + Factor; + If WantType = nil Then + RaiseError('ERROR - C_Expression - Term - Factor'); + ScriptData.GenCodeV(_Or, WantType.Size, 0, 0); + End; + sopXOr : + Begin + GetSym; + Factor; + If WantType = nil Then + RaiseError('ERROR - C_Expression - Term - Factor'); + ScriptData.GenCodeV(_XOr, WantType.Size, 0, 0); + End; + sopNot : + Begin + GetSym; + Factor; + If WantType = nil Then + RaiseError('ERROR - C_Expression - Term - Factor'); + If WantType.InternalType = intBoolean Then + ScriptData.GenCodeV(_Not, WantType.Size, 1, 0) + Else + ScriptData.GenCodeV(_Not, WantType.Size, 0, 0); + End; + sOpenBracket : + Begin + GetSym; + C_Expression(WantType); + FactorType := ExprResult; + + Expect([sCloseBracket]); + GetSym; + End; + sOpenBracketR : + Begin + If WantType = nil then WantType := Owner.decl_Set4; + //If WantType.InternalType = intAString Then + // RaiseError(ERR_UNALLOWED_STRING_ACTION); + If not (WantType.InternalType in Internalintegers + [intSet]) Then + RaiseError(ERR_UNALLOWED_STRING_ACTION); + + GetSym; + ScriptData.GenCode(_gen, WantType.Size, 0, 0); + If IdentSym <> sCloseBracketR Then + While True Do + Begin + C_Expression(Owner.decl_Enum); + ScriptData.GenCodeV(_ets, WantType.Size, 0, 0); + ScriptData.GenCodeV(_add, intSet, WantType.Size, 0); + + If IdentSym = sCloseBracketR Then break; + Expect([sComma]); + GetSym; + End; + FactorType := Owner.decl_Set4; + + Expect([sCloseBracketR]); + GetSym; + End; + sInteger : + Begin + //If WantType.InternalType = intAString Then + // RaiseError(ERR_UNALLOWED_STRING_ACTION); + If WantType.InternalType = intSingle then + begin + FactorType := Owner.decl_Single; + ScriptData.GenCodeV(_gen4, Single(IdentNum), 0, 0); + end + else + begin + FactorType := Owner.decl_Integer; + ScriptData.GenCode(_gen4, IdentNum, 0, 0); + end; + GetSym; + End; + sFloat : + Begin + FactorType := Owner.decl_Single; + ScriptData.GenCodeV(_gen4, Single(IdentNum), 0, 0); + GetSym; + End; + sNil : + Begin + FactorType := Owner.decl_Pointer; + ScriptData.GenCode(_gen4, 0, 0, 0); + GetSym; + End; + sString : + Begin + If (length(IdentStr) = 1) and (WantType.InternalType in [intAChar, intNone]) Then + Begin + ScriptData.GenCode(_Gen1, Ord(IdentStr[1]), 0, 0); + FactorType := Owner.decl_AChar; + End + Else + Begin + FactorType := Owner.decl_AString; + Bool := False; + For I := 0 To high(ResStrings) Do + If ResStrings[i].Value = IdentStr Then + Begin + ScriptData.GenCode(_rstr, ResStrings[i].Address, 0, 0); + Bool := True; + break; + End; + If not Bool Then + Begin + SetLength(ResStrings, length(ResStrings) + 1); + ResStrings[high(ResStrings)].Address := ScriptData.Ressources.Top + 4; + ResStrings[high(ResStrings)].Value := IdentStr; + ScriptData.GenCode(_rstr, ScriptData.Ressources.Top + 4, 0, 0); + ScriptData.Ressources.PushAStringData(IdentStr); + End; + End; + GetSym; + End; + Else + ErrorExpected([sInteger, sFloat, sString, sIdent, sOpenBracket], IdentSym); + End; + + If (WantType = nil) Then + WantType := FactorType + Else + If (FactorType <> nil) and (WantType <> FactorType) Then + Begin + If (OldWantType.InternalType = intNone) and + (WantType.InternalType in InternalIntegers) and + (FactorType.InternalType in InternalFloats) Then + Begin + ScriptData.CodeInsertPos := ConvPos; + WantType.ConvertTo(FactorType, ScriptData); + ScriptData.CodeInsertPos := -1; + WantType := FactorType; + End + Else + If not FactorType.ConvertTo(WantType, ScriptData) Then + RaiseError(ERR_INCOMPATIBLE_TYPES, + [WantType.Name, FactorType.Name]); + End; + End; + + (*Factor*) + Var + Operation : TRutisSymbol; + Begin(*Term*) + Factor; + If not gotStr then + begin + If (WantType.InternalType = intAString) Then + ScriptData.GenCode(_copyastr, 0, 0, 0); + If (WantType.InternalType = intWString) Then + ScriptData.GenCode(_copywstr, 0, 0, 0); + gotStr := True; + end; + + While IdentSym in [sStar, sSlash, sMod, sopAnd, sopOr, sopXOr] Do + Begin + Operation := IdentSym; + GetSym; + Factor; + If (WantType.InternalType in [intAString, intWString]) {and (Operation in [sStar, sSlash])} Then + RaiseError(ERR_UNALLOWED_STRING_ACTION); + + Case Operation Of + sStar : ScriptData.GenCodeV(_mult, WantType.InternalType, 0, 0); + sSlash : ScriptData.GenCodeV(_div, WantType.InternalType, 0, 0); + sMod : + Begin + If not (WantType.InternalType in InternalIntegers) Then + RaiseError(ERR_NEEDED_FOUND, ['ordinal type', WantType.Name]); + ScriptData.GenCodeV(_mod, WantType.InternalType, 0, 0); + End; + sopAnd : ScriptData.GenCodeV(_And, WantType.Size, 0, 0); + sopOr : ScriptData.GenCodeV(_Or, WantType.Size, 0, 0); + sopXOr : ScriptData.GenCodeV(_XOr, WantType.Size, 0, 0); + End; + End; + End; + + (*Term*) + //============================================================================== +Var + Operation : TRutisSymbol; + TempCodepos : Integer; +Begin (*Expresion*) + gotStr := False; + OldWantType := WantType; + If WantType <> nil Then + If WantType.InternalType = intBoolean Then + WantType := nil; + + If (IdentSym in [sPlus, sMinus]) Then + Begin + Operation := IdentSym; + + TempCodepos := 0; + If Operation = sMinus Then + TempCodepos := ScriptData.GenCode(_gen, -1, 0, 0); + + GetSym; + Term; + + If Operation = sMinus Then + Begin + ScriptData.Code[TempCodepos].P1 := WantType.Size; + ScriptData.GenCodeV(_sub, WantType.InternalType, 0, 0); + End; + End + Else + Term; + While (IdentSym in [sPlus, sMinus]) Do + Begin + Operation := IdentSym; + GetSym; + Term; + Case Operation Of + sPlus : ScriptData.GenCodeV(_add, WantType.InternalType, WantType.Size, 0); + sMinus : ScriptData.GenCodeV(_sub, WantType.InternalType, WantType.Size, 0); + End; + End; + If (IdentSym in [sEqual..sUnEqual]) Then + Begin + If not (OldWantType.InternalType in [intNone, intBoolean]) Then + RaiseError( + ERR_INCOMPATIBLE_TYPES, + [OldWantType.Name, Owner.decl_Boolean.Name]); + + Operation := IdentSym; + GetSym; + //C_Expression(nil); + C_Expression(WantType); + + If (ExprResult.InternalType in [intNone, intRecord, intShortString]) Then + RaiseError('Value expected'); + Case Operation Of + sEqual : ScriptData.GenCodeV(_opr, ocEqual, WantType.InternalType, ExprResult.InternalType); + sBigger : ScriptData.GenCodeV(_opr, ocGreater, WantType.InternalType, ExprResult.InternalType); + sSmaller : ScriptData.GenCodeV(_opr, ocLess, WantType.InternalType, ExprResult.InternalType); + sBiggerEqual : ScriptData.GenCodeV(_opr, ocGEqual, WantType.InternalType, ExprResult.InternalType); + sSmallerEqual : ScriptData.GenCodeV(_opr, ocLEqual, WantType.InternalType, ExprResult.InternalType); + sUnEqual : ScriptData.GenCodeV(_opr, ocUnequal, WantType.InternalType, ExprResult.InternalType); + End; + WantType := Owner.decl_Boolean; + End; + ExprResult := WantType; +End; (*Expression*) + +Procedure TRutisCompilerDelphi.C_StatementSequence; + + Procedure Statement; + Var + Inf : TAnalyzeIdentInfo; + //================================ + (*Condition*) + Procedure IfStruct; + Var + FailJumpPos, fCodePosition2 : Integer; + Begin + GetSym; + + C_Expression(Owner.decl_Boolean); + + Expect([sThen]); + GetSym; + + ScriptData.GenCodeV(_JZ, 0, intBoolean, 0); + FailJumpPos := high(ScriptData.Code); + + Statement; + + If IdentSym <> sSemicolon Then + Begin + ScriptData.GenCode(_jmp, 0, 0, 0); + fCodePosition2 := high(ScriptData.Code); + + ScriptData.Code[FailJumpPos].P1 := high(ScriptData.Code) + 1; + + While IdentSym = sElseIf Do + Begin + GetSym; + C_Expression(Owner.decl_Boolean); + Expect([sThen]); + GetSym; + + ScriptData.GenCodeV(_JZ, 0, intBoolean, 0); + FailJumpPos := high(ScriptData.Code); + + Statement; + + ScriptData.GenCode(_jmp, 0, 0, 0); + ScriptData.Code[fCodePosition2].P1 := high(ScriptData.Code); + fCodePosition2 := high(ScriptData.Code); + + ScriptData.Code[FailJumpPos].P1 := high(ScriptData.Code) + 1; + End; + If IdentSym = sElse Then + Begin + GetSym; + Statement; + End + Else + If IdentSym <> sElseIf Then + RaiseError('If-Semicolon'); + + ScriptData.Code[fCodePosition2].P1 := high(ScriptData.Code) + 1; + End + Else + ScriptData.Code[FailJumpPos].P1 := high(ScriptData.Code) + 1; + End; + //================================ + Procedure WhileStruct; + Var + StartPos, + EndPos, i : Integer; + Begin + GetSym; + StartPos := high(ScriptData.Code) + 1; + + //==== Check Loop-Condition + C_Expression(Owner.decl_Boolean); + + Expect([sDo]); + GetSym; + + ScriptData.GenCodeV(_JZ, 0, intBoolean, 0); + EndPos := high(ScriptData.Code); + + //==== Loop-Code + Inc(LoopDepth); + Statement; + Dec(LoopDepth); + + //==== Jump to Loop-Start + ScriptData.GenCode(_jmp, StartPos, 0, 0); + ScriptData.Code[EndPos].P1 := high(ScriptData.Code) + 1; + + //==== Continue / Break Jumps + For i := EndPos + 1 To high(ScriptData.Code) Do + Begin + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -10) Then + ScriptData.Code[i].P1 := StartPos; + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -20) Then + ScriptData.Code[i].P1 := high(ScriptData.Code) + 1; + End; + End; + + Procedure RepeatStruct; + Var + StartPos, i : Integer; + Begin + GetSym; + StartPos := high(ScriptData.Code) + 1; + + //==== Loop-Code + Inc(LoopDepth); + C_StatementSequence; + Dec(LoopDepth); + + Expect([sUntil]); + GetSym; + + //==== Check Loop-Condition + C_Expression(Owner.decl_Boolean); + + ScriptData.GenCodeV(_JZ, StartPos, intBoolean, 0); + + //==== Continue / Break Jumps + For i := StartPos To high(ScriptData.Code) Do + Begin + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -10) Then + ScriptData.Code[i].P1 := StartPos; + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -20) Then + ScriptData.Code[i].P1 := high(ScriptData.Code) + 1; + End; + End; + + Procedure ForStruct; + Var + i, + StartPos : Integer; + downtoloop : Boolean; + IdentVar : TRutisVarDecl; + Begin + GetSym; + + Expect([sIdent]); + + IdentVar := TRutisVarDecl(GetDeclaration(IdentStr)); + + If (IdentVar = nil) Then + Begin + RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); + exit; + End; + If not (IdentVar is TRutisVarDecl) Then + Begin + RaiseError(ERR_VAR_EXPECTED); + exit; + End; + If not (IdentVar.VarType is TRutisVarType) Then + Begin + RaiseError(ERR_VAR_EXPECTED); + exit; + End; + If not (IdentVar.VarType.InternalType in InternalIntegers) Then + Begin + RaiseError(ERR_EXPECTED, ['Integer']); + exit; + End; + GetSym; + + Expect([sBecomes]); + GetSym; + + //==== Loop-Start Value + C_Expression(IdentVar.VarType); + With IdentVar Do + ScriptData.GenCode(_sto, Address, Level, IdentVar.VarType.Size); + + downtoloop := IdentSym = sDownTo; + If not downtoloop and not Expect([sTo]) Then exit; + GetSym; + + //==== Loop-End Value + C_Expression(IdentVar.VarType); + case IntTypeSizes[IdentVar.VarType.InternalType] of + 1 : ScriptData.GenCode(_gen1, 1, 0, 0); + 2 : ScriptData.GenCode(_gen2, 1, 0, 0); + 4 : ScriptData.GenCode(_gen4, 1, 0, 0); + else + RaiseError(ERR_UNEXPECTED_ERROR); + end; + ScriptData.GenCodeV(_add, IdentVar.VarType.InternalType, 0, 0); + + Expect([sDo]); + GetSym; + + StartPos := high(ScriptData.Code) + 1; + + //==== Check Loop-End + With IdentVar Do + Begin + ScriptData.GenCode(_lod, -VarType.Size, 0, VarType.Size); + ScriptData.GenCode(_lod, Address, Level, VarType.Size); + ScriptData.GenCodeV(_sub, VarType.InternalType, 0, 0); + If downtoloop Then + ScriptData.GenCodeV(_JGZ, 0, VarType.InternalType, 0) + Else + ScriptData.GenCodeV(_JLZ, 0, VarType.InternalType, 0); + End; + + //==== Loop-Code + Inc(LoopDepth); + Statement; + Dec(LoopDepth); + + //==== i := i + 1 // i := i - 1 + If downtoloop Then + ScriptData.GenCode(_gen4, -1, 0, 0) + Else + ScriptData.GenCode(_gen4, 1, 0, 0); + With IdentVar Do + ScriptData.GenCode(_inc, Address, Level, Word(VarType.InternalType)); //} + + //==== Jump to Loop-Start + ScriptData.GenCode(_jmp, StartPos, 0, 0); + ScriptData.Code[StartPos + 3].P1 := high(ScriptData.Code) + 1; + + //==== Continue / Break Jumps + For i := StartPos To high(ScriptData.Code) Do + Begin + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -10) Then + ScriptData.Code[i].P1 := high(ScriptData.Code) - 2; + + If (ScriptData.Code[i].Cmd = _jmp) and + (ScriptData.Code[i].P1 = -20) Then + ScriptData.Code[i].P1 := high(ScriptData.Code) + 1; + End; + + ScriptData.GenCode(_pupo, -IdentVar.VarType.Size, 0, 0); + End; + //================================ + Procedure IdentFoundHandler; + Var + InsertPos : Integer; + Begin + If IdentStr = '' Then exit; + + With Inf Do + Begin + InsertPos := high(ScriptData.Code) + 1; + + Case C_AnalyzeIdent(False, intNone, Inf) Of + itVar : + Begin + Expect([sBecomes]); + GetSym; + + case Inf.TypeData.InternalType of + intAString: ScriptData.GenCode(_StoAStr, Adr, Lvl, 0); + intWString: ScriptData.GenCode(_StoWStr, Adr, Lvl, 0); + Else + ScriptData.GenCode(_sto, Adr, Lvl, Inf.TypeData.Size); + end; + + // Insert expression code before store-statements + ScriptData.CodeInsertPos := InsertPos; + C_Expression(Inf.TypeData); + End; + itPVar : + Begin + Expect([sBecomes]); + GetSym; + + If Lvl = -1 Then Adr := -4; + + case Inf.TypeData.InternalType of + intAString: ScriptData.GenCode(_StoAStr, Adr, Lvl, 1); + intWString: ScriptData.GenCode(_StoWStr, Adr, Lvl, 1); + Else + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + end; + + // Insert expression code before store-statements + ScriptData.CodeInsertPos := InsertPos; + C_Expression(Inf.TypeData); + End; + itConst : RaiseError(ERR_NO_CONST_ALLOWED); + itError : RaiseError(ERR_UNKNOWN_IDENT, [LowerCase(IdentStr)]); + End; + // Reset Insert-Pos + ScriptData.CodeInsertPos := -1; + End; + End; + //================================ + Procedure Code_SetLength; + Begin + With Inf Do + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + //AllowedIdents := [VArray, VString]; + C_AnalyzeIdent(False, intNone, Inf); + If not (Inf.TypeData.InternalType in [intArray, intAString]) Then + Begin + RaiseError(ERR_EXPECTED, ['Array, AnsiString']); + exit; + End; + + Case Inf.IdentType Of + itVar : ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_lodp, Adr, Lvl, Inf.TypeData.Size); + End; + Else + RaiseError('ERROR - SetLength'); + exit; + End; + + Expect([sComma]); + GetSym; + C_Expression(Owner.decl_Integer); + If not (ExprResult.InternalType in InternalIntegers) Then + RaiseError(ERR_EXPECTED_FOUND, ['Integer', ExprResult.Name]); + + Expect([sCloseBracket]); + GetSym; + + If TypeData is TRutisArrayType Then + Begin + ScriptData.GenCode(_gen4, TRutisArrayType(TypeData).ArrayType.Size, 0, 0); + ScriptData.GenCode(_smem, 0, 0, 0); + End + Else + Begin + If Inf.TypeData.InternalType = intAString Then + Begin + ScriptData.GenCode(_SASL, 0, 0, 0); + End + Else + Begin + RaiseError('ERROR'); exit; + End; + End; + + Case IdentType Of + itVar : ScriptData.GenCode(_sto, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + Begin + ScriptData.GenCode(_lod, -8, -1, 4); + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_pupo, -4, 0, 0); + End + Else + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + End; + End; + //If MethodResult.TypeData = VArray then + //begin + + //end; + End; + End; + + Procedure Code_ReallocMem; + Begin + With Inf Do + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + C_AnalyzeIdent(False, intPointer, Inf); + + If not (Inf.TypeData.InternalType in [intPointer, intArray]) Then + Begin + RaiseError(ERR_EXPECTED, ['Pointer']); + exit; + End; + + Case Inf.IdentType Of + itVar : ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_lodp, Adr, Lvl, Inf.TypeData.Size); + End; + Else + RaiseError('ERROR - ReallocMem'); + exit; + End; + + Expect([sComma]); + GetSym; + C_Expression(Owner.decl_Integer); + If not (ExprResult.InternalType in InternalIntegers) Then + RaiseError(ERR_EXPECTED_FOUND, ['Integer', ExprResult.Name]); + + Expect([sCloseBracket]); + GetSym; + + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCode(_smem, 0, 0, 0); + + Case IdentType Of + itVar : ScriptData.GenCode(_sto, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + Begin + ScriptData.GenCode(_lod, -8, -1, 4); + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_pupo, -4, 0, 0); + End + Else + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + End; + End; + End; + End; + + Procedure Code_New; + Begin + With Inf Do + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + C_AnalyzeIdent(False, intPointer, Inf); + + If not (Inf.TypeData is TRutisPointerType) Then + Begin + RaiseError(ERR_EXPECTED, ['typed Pointer']); + exit; + End; + + Case Inf.IdentType Of + itVar : ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_lodp, Adr, Lvl, Inf.TypeData.Size); + End; + Else + RaiseError('ERROR - New'); + exit; + End; + Expect([sCloseBracket]); + GetSym; + + ScriptData.GenCode(_gen4, TRutisPointerType(Inf.TypeData).PointerType.Size, 0, 0); + ScriptData.GenCode(_gen4, 1, 0, 0); + ScriptData.GenCode(_smem, 0, 0, 0); + + Case IdentType Of + itVar : ScriptData.GenCode(_sto, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + Begin + ScriptData.GenCode(_lod, -8, -1, 4); + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_pupo, -4, 0, 0); + End + Else + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + End; + End; + End; + End; + + Procedure Code_Dispose; + Begin + With Inf Do + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + C_AnalyzeIdent(False, intPointer, Inf); + + If not (Inf.TypeData.InternalType in [intPointer, intArray]) Then + Begin + RaiseError(ERR_EXPECTED, ['Pointer']); + exit; + End; + + Case Inf.IdentType Of + itVar : ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + ScriptData.GenCode(_lod, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_lodp, Adr, Lvl, Inf.TypeData.Size); + End; + Else + RaiseError('ERROR - New'); + exit; + End; + Expect([sCloseBracket]); + GetSym; + + ScriptData.GenCode(_gen4, 0, 0, 0); + ScriptData.GenCode(_gen4, 0, 0, 0); + ScriptData.GenCode(_smem, 0, 0, 0); + + Case IdentType Of + itVar : ScriptData.GenCode(_sto, Adr, Lvl, Inf.TypeData.Size); + itPVar : + Begin + If Lvl = -1 Then + Begin + ScriptData.GenCode(_lod, -8, -1, 4); + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + ScriptData.GenCode(_pupo, -4, 0, 0); + End + Else + ScriptData.GenCode(_stop, Adr, Lvl, Inf.TypeData.Size); + End; + End; + End; + End; + //================================ + Var + i : Integer; + sym : TRutisSymbol; + Begin (*Statement*) + If CompilingUnit Then + ScriptData.CompilerLine := -1 + Else + ScriptData.CompilerLine := ScannerLine; + + sym := IdentSym; + Case sym Of + sIdent : IdentFoundHandler; + sIf : IfStruct; + sWhile : WhileStruct; + sRepeat : RepeatStruct; + sFor : ForStruct; + sWrite : + Begin + GetSym; + C_Expression(nil); + ScriptData.GenCodeV(_wri, ExprResult.InternalType, 0, 0); + End; + sNop : + Begin + ScriptData.GenCode(_nocmd, 0, 0, 0); + GetSym; + End; + sTerminate : + Begin + ScriptData.GenCode(_jmp, -5, 0, 0); + GetSym; + End; + sInc, + sDec : + Begin + GetSym; + Expect([sOpenBracket]); + GetSym; + + If sym = sInc Then + ScriptData.GenCode(_Gen4, 1, 0, 0) + Else + ScriptData.GenCode(_Gen4, -1, 0, 0); + i := high(ScriptData.Code); + + C_AnalyzeIdent(False, intNone, Inf); + + If IdentSym = sComma Then + Begin + GetSym; + If i < high(ScriptData.Code) Then + Begin + RaiseError('ERROR - Statement'); exit; + End; + SetLength(ScriptData.Code, length(ScriptData.Code) - 1); + If sym = sDec Then + ScriptData.GenCode(_Gen4, 0, 0, 0); + C_Expression(Owner.decl_Integer); + If sym = sDec Then + ScriptData.GenCodeV(_Sub, intInteger, 0, 0); + End; + + With Inf Do + Case Inf.IdentType Of + itVar : ScriptData.GenCodeV(_inc, Adr, Lvl, Inf.TypeData.InternalType); + //itPVar : ScriptData.GenCode(_incp, Adr, Lvl, Inf.TypeData.Size); + Else + RaiseError('ERROR - Value expected'); exit; + exit; + End; + + Expect([sCloseBracket]); + GetSym; + End; + sSetLength : Code_SetLength; + sReallocMem : Code_ReallocMem; + sNew : Code_New; + sDispose : Code_Dispose; + sContinue : + Begin + If LoopDepth <= 0 Then + Begin + RaiseError('Continue and Break can only be used in loops'); + exit; + End; + ScriptData.GenCode(_jmp, -10, 0, 0); + GetSym; + End; + sBreak : + Begin + If LoopDepth <= 0 Then + Begin + RaiseError('Continue and Break can only be used in loops'); + exit; + End; + ScriptData.GenCode(_jmp, -20, 0, 0); + GetSym; + End; + sExit : + Begin + ScriptData.GenCode(_ret, ExitParamsSize, 0, 0); + GetSym; + End; + sBegin : + Begin + GetSym; + C_StatementSequence; + + If IdentSym <> sEnd Then + Begin + RaiseError(ERR_OP_OR_SEMI_EXPECTED); + exit; + End; + //Expect([sEnd]); + GetSym; + End; + Else + (*Der Fehler darf getrost ignoriert werden*) + //Error(ERR_UNALLOWED_STATEMENT) + End; + End; (*Statement*) + +Begin (*Statement Sequence*) + Statement; + While IdentSym = sSemiColon Do + Begin + GetSym; + Statement; + End; +End; (*Statement Sequence*) + +//============================================================================== +//============================================================================== + +Function TRutisCompilerDelphi.GetDeclaration(Name : AnsiString) : TRutisDecl; +Var + i : Integer; +Begin + For i := high(UnitNamespaces) Downto 0 Do + Begin + Result := ScriptData.GetDeclaration(Name, UnitNamespaces[i]); + If Result <> nil Then exit; + End; + Result := ScriptData.GetDeclaration(Name, '$SYSTEM'); + If Result <> nil Then exit; + Result := ScriptData.GetDeclaration(Name, '$STATIC'); +End; + +Function TRutisCompilerDelphi.GetDeclaration(Name : AnsiString; Exclude : Array Of TRutisDecl) : TRutisDecl; +Var + i : Integer; +Begin + For i := high(UnitNamespaces) Downto 0 Do + Begin + Result := ScriptData.GetDeclaration(Name, UnitNamespaces[i], Exclude); + If Result <> nil Then exit; + End; + Result := ScriptData.GetDeclaration(Name, '$SYSTEM', Exclude); + If Result <> nil Then exit; + Result := ScriptData.GetDeclaration(Name, '$STATIC', Exclude); +End; + +Function TRutisCompilerDelphi.GetDeclarationID(Name : AnsiString) : Integer; +Var + i : Integer; +Begin + For i := high(UnitNamespaces) Downto 0 Do + Begin + Result := ScriptData.GetDeclarationId(Name, UnitNamespaces[i]); + If Result <> -1 Then exit; + End; + Result := ScriptData.GetDeclarationId(Name, '$SYSTEM'); +End; + +Function TRutisCompilerDelphi.CheckRedefinition(Name : AnsiString) : Boolean; +Begin + Result := ScriptData.GetDeclarationId(Name, CurrentNamespace) <> -1; + If not Result Then + Result := ScriptData.GetDeclarationId(Name, '$SYSTEM') <> -1; + If not Result Then + Result := ScriptData.GetDeclarationId(Name, '$STATIC') <> -1; + //If Result Then + // RaiseError(ERR_INDENT_REDEFINED, [Name]); +End; + +//============================================================================== +//============================================================================== + +Procedure TRutisCompilerDelphi.PushScanner; +Begin + PushScannerLine := ScannerLine; + PushScannerStrPos := ScannerStrPos; + PushScannerCh := ScannerCh; + PushIdentSym := IdentSym; +End; + +Procedure TRutisCompilerDelphi.PopScanner; +Begin + ScannerLine := PushScannerLine; + ScannerStrPos := PushScannerStrPos; + ScannerCh := PushScannerCh; + IdentSym := PushIdentSym; +End; + +//============================================================================== + +Procedure TRutisCompilerDelphi.PushCompilerState; +Begin + SetLength(CompilerStates, length(CompilerStates) + 1); + With CompilerStates[high(CompilerStates)] Do + Begin + CSScannerLine := ScannerLine; + CSScannerStrPos := ScannerStrPos; + CSScannerCh := ScannerCh; + CSIdentSym := IdentSym; + CSCodePos := length(ScriptData.Code); + End; +End; + +Procedure TRutisCompilerDelphi.PopCompilerState; +Begin + With CompilerStates[high(CompilerStates)] Do + Begin + ScannerLine := CSScannerLine; + ScannerStrPos := CSScannerStrPos; + ScannerCh := CSScannerCh; + IdentSym := CSIdentSym; + SetLength(ScriptData.Code, CSCodePos); + End; + SetLength(CompilerStates, length(CompilerStates) - 1); +End; + +//============================================================================== + +Procedure TRutisCompilerDelphi.GetSym; +Var + doUpCase : Boolean; + + Procedure GetCh; + Begin + If ScannerStrPos < 1 Then + ScannerStrPos := 1; + If ScannerLine > ScriptCode.Count - 1 Then + Begin + ScannerCh := #255; + exit; + End; + If ScannerLine < 0 Then + Begin + ScannerLine := 0; + ScannerStrPos := 1; + ScannerCh := ' '; + exit; + End; + If ScannerStrPos > length(ScriptCode[ScannerLine]) Then + Begin + Inc(ScannerLine); + ScannerStrPos := 1; + ScannerCh := ' '; + exit; + End; + ScannerCh := ScriptCode[ScannerLine][ScannerStrPos]; + If doUpCase Then + ScannerCh := UpCase(ScannerCh); //Case in-sensitiVe + Inc(ScannerStrPos); + End; + +Var + sym : TRutisSymbol; +Begin + LastScannerLine := ScannerLine; + LastScannerStrPos := ScannerStrPos; + doUpCase := True; + While True Do + Begin + IdentSym := sNone; + IdentStr := ''; + While ScannerCh in [' ', #0, #13, #10] Do + GetCh; + + Case ScannerCh Of + 'A'..'Z', '_' : (*Ident/ReserVed Word*) + Begin + While ScannerCh in ['A'..'Z', '_', '0'..'9'] Do + Begin + IdentStr := IdentStr + ScannerCh; + GetCh; + End; + IdentSym := sIdent; + + For sym := sUnknown To sNone Do + If IdentStr = cSymbols[sym] Then + Begin + IdentSym := sym; + Break; + End; + Exit; + End; + + ';', '+', '-', '=', ',', '.', '*', '(', ')', '^', '@', '[', ']' : + Begin (*IdentSyme die nur aus 1 Zeichen bestehen können*) + IdentStr := ScannerCh; + IdentSym := sUnknown; + For sym := sUnknown To sNone Do + If IdentStr = cSymbols[sym] Then + Begin + IdentSym := sym; + Break; + End; + GetCh; + Exit; + End; (*IdentSyme die nur aus 1 Zeichen bestehen können*) + + ':', '<', '>' : + Begin + IdentStr := ScannerCh; + GetCh; + If ScannerCh in ['=', '<', '>'] Then + Begin + IdentStr := IdentStr + ScannerCh; + GetCh; + End; + For sym := sUnknown To sNone Do + If IdentStr = cSymbols[sym] Then + Begin + IdentSym := sym; + Break; + End; + exit; + End; + + '/' : (* Zeichen die ein naScannerChfolgendes Zeichen haben können(in diesm Falle ein = )*) + Begin + IdentStr := ScannerCh; + GetCh; + If ScannerCh = '/' Then + Begin + Inc(ScannerLine); + ScannerStrPos := 1; + GetCh; + continue; + End + Else + Begin + IdentSym := sSlash; + exit; + End; + End; + + '{' : + Begin + Repeat + GetCh; + Until (ScannerCh = '}') or (ScannerCh = #255); + GetCh; + continue; + End; + + ''''{'} :(*Strings*) + Begin + IdentSym := sString; + doUpCase := False; + GetCh; + IdentStr := ''; + If (ScannerCh = '''') Then + GetCh + Else + While True Do + Begin + IdentStr := IdentStr + ScannerCh; + GetCh; + If (ScannerCh = '''') Then + Begin + GetCh; + If (ScannerCh <> '''') Then + Break; + End; + If ScannerCh = #255 Then + exit; + End; + doUpCase := True; + exit; + End; + + '0'..'9', '$' : (*Zahlen*) + Begin + IdentSym := sInteger; + IdentStr := ScannerCh; + GetCh; + If (IdentStr = '$') Then + Begin + //HexZahl + While ScannerCh in ['0'..'9', 'A'..'F'] Do + Begin + IdentStr := IdentStr + ScannerCh; + GetCh; + End; + IdentNum := StrToInt(IdentStr); + Exit; + End + Else + Begin + //NormaleZahl + While ScannerCh in ['0'..'9', '.', 'E'] Do + Begin + IdentStr := IdentStr + ScannerCh; + If (ScannerCh = '.') or + (ScannerCh = 'E') Then + IdentSym := sFloat; + GetCh; + End; + If IdentSym = sInteger Then + IdentNum := StrToInt(IdentStr) + Else + IdentNum := StrToFloat(IdentStr); + Exit; + End; + End; (*Zahlen*) + #255 : exit; + Else + RaiseError(ERR_SCANNER_UNEXPECTED_CHAR + ': ''' + ScannerCh + ''''); + exit; + End; + End; +End; + +//============================================================================== + +End. + diff --git a/Units/RUTIS/RUTIS_Errors.pas b/Units/RUTIS/RUTIS_Errors.pas new file mode 100644 index 0000000..2fbd6b9 --- /dev/null +++ b/Units/RUTIS/RUTIS_Errors.pas @@ -0,0 +1,50 @@ +Unit RUTIS_Errors; + +Interface + +Resourcestring + ERR_UNEXPECTED_ERROR = 'E000: Unexpected error occurred. Please contect the support!'; + + ERR_SCANNER_UNEXPECTED_CHAR = 'E010: Unexpected char found in code'; + ERR_UNIT_NOT_FOUND = 'E011: Unit ''%s'' not found'; + ERR_FILENAME_NOT_UNITNAME = 'E012: Name of the unit is not the same as the filename'; + ERR_NOT_IMPLEMENTED_YET = 'E013: This function is not implemented in RUTIS at this time - Please wait for me to implement it'; + ERR_NOT_AVAILABLE = 'E014: This function is not available in this Version of RUTIS'; + ERR_NOT_AVAILABLE_C_TYPE = 'E015: This type of const is not available in RUTIS at this time'; + + ERR_UNKNOWN_IDENT = 'E020: Unknown Identifier ''%s'''; + ERR_INDENT_REDEFINED = 'E021: Identifier redefined ''%s'''; + ERR_UNKNOWN_TYPE = 'E022: Unknown type ''%s'''; + ERR_UNALLOWED_STATEMENT = 'E023: Unallowed Statement'; + + ERR_EXPECTED_FOUND = 'E030: ''%s'' expected, ''%s'' found instead'; + ERR_NEEDED_FOUND = 'E031: ''%s'' needed, ''%s'' found instead'; + ERR_OP_OR_SEMI_EXPECTED = 'E032: Operator or semicolon expected'; + ERR_VAR_CONSTANT_EXPECTED = 'E033: Variable or Constant expected'; + ERR_VAR_EXPECTED = 'E034: Variable expected'; + ERR_REC_EXPECTED = 'E035: Record expected'; + ERR_ARRAY_EXPECTED = 'E036: Array expected'; + ERR_PROCEDURE_EXPECTED = 'E037: Procedure expected'; + ERR_STRING_EXPECTED = 'E038: String expected'; + ERR_TYPE_EXPECTED = 'E039: Type expected'; + ERR_EXPECTED = 'E040: ''%s'' expected'; + + ERR_NOT_ENOUGH_PARAMETERS = 'E070: Not enough actual parameters'; + ERR_TOO_MANY_PARAMETERS = 'E071: Too many parameters'; + ERR_ONLY_PARAMLESS_PROCS = 'E072: Only parameterless procedures are allowed'; + ERR_NO_CONST_ALLOWED = 'E073: No constant allowed here'; + ERR_NO_OVERLOADED_FUNC = 'E073: There is no overloaded function with these parameters'; + + ERR_UNALLOWED_STRING_ACTION = 'E080: Unallowed String action'; + ERR_POINTER_ONLY_FOR_VAR = 'E081: Pointers can only be created for vars'; + + ERR_INCOMPATIBLE_TYPES = 'E090: Incompatible types ''%s'' and ''%s'''; + ERR_UNALLOWED_DATATYPE = 'E091: Unallowed type'; + + ERR_CODE_AFTER_PROGRAM_END = 'W001: Code after Program END. is ignored'; + ERR_CODE_AFTER_UNIT_END = 'W002: Code after Unit END. is ignored'; + +Implementation + +End. + diff --git a/Units/RUTIS/RUTIS_Errors.rst b/Units/RUTIS/RUTIS_Errors.rst new file mode 100644 index 0000000..4600c84 --- /dev/null +++ b/Units/RUTIS/RUTIS_Errors.rst @@ -0,0 +1,82 @@ + +# hash value = 257594117 +rutis_errors.err_scanner_unexpected_char='E000: Unexpected char found in '+ +'code' + + +# hash value = 23719812 +rutis_errors.err_unallowed_statement='E002: Unallowed Statement' + + +# hash value = 248294455 +rutis_errors.err_unknown_ident='E003: Unknown Identifier '#39'%s'#39 + +# hash value = 195210244 +rutis_errors.err_expected_found='E010: '#39'%s'#39' expected, '#39'%s'#39+ +' found instead' + + +# hash value = 2386388 +rutis_errors.err_op_or_semi_expected='E011: Operator or semicolon expecte'+ +'d' + + +# hash value = 184443412 +rutis_errors.err_var_constant_expected='E012: Variable or Constant expect'+ +'ed' + + +# hash value = 80568548 +rutis_errors.err_var_expected='E013: Variable expected' + + +# hash value = 25156852 +rutis_errors.err_rec_expected='E014: Record expected' + + +# hash value = 95149172 +rutis_errors.err_array_expected='E015: Array expected' + + +# hash value = 90164228 +rutis_errors.err_procedure_expected='E016: Procedure expected' + + +# hash value = 50540276 +rutis_errors.err_string_expected='E017: String expected' + + +# hash value = 51366068 +rutis_errors.err_expected='E019: %s expected' + + +# hash value = 159220885 +rutis_errors.err_no_const_allowed='E020: No Constant allowed here' + + +# hash value = 3854691 +rutis_errors.err_not_enough_parameters='E030: Not enough actual parameter'+ +'s' + + +# hash value = 50133859 +rutis_errors.err_too_many_parameters='E031: Too many parameters' + + +# hash value = 62647742 +rutis_errors.err_unallowed_string_action='E040: Unallowed String action' + + +# hash value = 255120181 +rutis_errors.err_unallowed_datatype='E041: Unallowed Datatype' + + +# hash value = 91098180 +rutis_errors.err_code_after_program_end='W001: Code after Program END. is'+ +' ignored' + + +# hash value = 102976020 +rutis_errors.err_code_after_unit_end='W002: Code after Unit END. is ignor'+ +'ed' + diff --git a/Units/RUTIS/Rutis_Defs.pas b/Units/RUTIS/Rutis_Defs.pas new file mode 100644 index 0000000..ab98cd5 --- /dev/null +++ b/Units/RUTIS/Rutis_Defs.pas @@ -0,0 +1,1482 @@ +{/============================================================================== +//============================================================================== + +RUTIS-Engine (RunTimeScript-Engine) + +Rutis_Defs.pas (part of) RUTIS-Engine + +--> This unit contains the types, defines, functions, etc. + which are used by the RUTIS-Engine + +//============================================================================== + +Author : Björn Zeutzheim +E-Mail : bjoern@zeutzheim-boppard.de + +//============================================================================== + +License: Dieses Projekt (RUTIS-Engine) steht unter einer / + This project is licensed under the + Creative Commons 3.0 BY-NC-SA (German) License + +Diese Lizens beinhaltet / This license includes: +-> Namensnennung / Attribution +-> Keine kommerzielle Nutzung / Noncommercial +-> Weitergabe unter gleichen Bedingungen / Share Alike + +Ein ausformulierter Lizensvertrag ist über folgende Adresse erreichbar: +The Legal Code (the full license) can be read at the following adress: +> http: //creativecommons.org/licenses/by-nc-sa/3.0/de/ + +//============================================================================== +//==============================================================================} + +Unit Rutis_Defs; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +Uses + Windows, {$ifdef DELPHI_7_UP}Variants, {$endif} + SysUtils, Rutis_Stack; + + //==================================================================== + //==================================================================== + +Type + TOperatorCode = (ocEqual, ocGreater, ocLess, ocGEqual, ocLEqual, ocUnequal{, ocAnd, ocOr, ocXOr, ocNot}); + + TVariantArray = Array Of Variant; + PVariantArray = ^TVariantArray; + + //==================================================================== +{$REGION 'Exceptions'} + ERutisCompilerError = Class(Exception) + Public + ENamespace : String; + ELine : Integer; + EChrPos : Integer; + Constructor Create(Msg, Namespace : String); Overload; + Constructor Create(Msg, Namespace : String; CLine, CPos : Integer); Overload; + Constructor CreateFmt(Const Msg : String; Const Args : Array Of Const; Namespace : String); Overload; + Constructor CreateFmt(Const Msg : String; Const Args : Array Of Const; Namespace : String; CLine, CPos : Integer); Overload; + Procedure Assign(E : ERutisCompilerError); + End; + +{$ENDREGION} + +//==================================================================== +{$REGION 'Commands'} +//==================================================================== +//==================================================================== +//Byte-Code Commands + +Type + TRutisCmd = (_gen, _gen1, _gen2, _gen4, + _lod, _sto, _mov, // Stack Variables + _lodp, _stop, + _at, _at2, _Ptr, _PtrP, _CPtr, + _CopyAStr, _CopyWStr, _StoAStr, _StoWStr, + _SMem, _MemS, + _getCh, _setCh, _GASL, _SASL, _GWSL, _SWSL, + _pupo, + _call, _ret, _ext, // Call + _add, _sub, _mult, _div, _mod, _ets, // math + _inc, _conv, // other math + _opr, _And, _Or, _XOr, _Not, // Opr + _jmp, _JZ, _JL, _JG, _JLZ, _JGZ, + _wri, _lodr, _RStr, // others (write,ressource) + _nocmd); + +Const + cCmd : Array[TRutisCmd] Of ShortString = ( + 'gen', 'gen1', 'gen2', 'gen4', + 'lod', 'sto', 'mov', // Stack Global Vriables + 'lodp', 'stop', {'movp',} + 'at', 'at2', 'ptr', 'ptrp', 'cptr', + 'castr', 'cwstr', 'sastr', 'swstr', + 'smem', 'meml', + 'getch', 'setch', 'getasl', 'setasl', 'getwsl', 'setwsl', + 'pupo', + 'call', 'ret', 'ext', // Call + 'add', 'sub', 'mult', 'div', 'mod', 'ets', // math + 'inc', 'conv', // other math + 'opr', 'and', 'or', 'xor', 'not', // Opr + 'jmp', 'jz', 'jl', 'jg', 'jlz', 'jgz', + 'wri', 'lodr', 'rstr', // others (write,ressource) + 'nop'); + + CmdParamCount : Array[TRutisCmd] Of Byte = ( + 1, 1, 1, 1, + 3, 3, 3, // Stack Global Vriables + 3, 3, + 0, 0, 2, 2, 0, + 0, 0, 3, 3, + 0, 0, + 0, 0, 0, 0, 0, 0, + 1, + 2, 1, 2, // Call + 2, 2, 1, 1, 1, 1, // math + 3, 2, // other math + 3, 1, 1, 1, 2, // Opr + 1, 2, 2, 2, 2, 2, + 1, 2, 1, // others (write,ressource) + 0); + +Const + LongCMD : Array[TRutisCmd] Of ShortString = ( + 'GenVar ', 'GenByte ', 'GenWord ', + 'GenCardinal', 'Load ', 'Store ', + 'Move ', 'LoadFromPtr', 'StoreAtPtr ', + 'GetAddr ', 'GetAddr2 ', 'GetPtr ', + 'PtrP ', 'CheckPtr ', + 'CopyAStr ', 'CopyWStr ', + 'StoreAStr ', 'StoreWStr ', + 'ScaleMem ', 'MemSize ', + 'GetChar ', 'SetChar ', + 'GetAStrLen ', 'SetAStrLen ', + 'GetWStrLen ', 'SetWStrLen ', + 'PushOrPop ', + 'Call ', 'Return ', 'ExtCall ', + 'Add ', 'Sub ', 'Mult ', + 'Div ', 'Modulo ', 'EnumToSet ', + 'Inc ', 'Convert ', + 'Operand ', 'And ', 'Or ', + 'XOr ', 'Not ', + 'Jump ', 'JumpFalse ', + 'JmpLess ', 'JmpGreater ', + 'JmpLessZ ', 'JmpGreaterZ', + 'Write ', 'LoadRes ', 'LoadResStr ', + 'NoOperation'); + +Type + TRutisScriptCmd = Record + Cmd : TRutisCmd; // Befehl + P1 : Integer; // Parameter 1 + P2 : Integer; // Parameter 2 + P3 : Word; // Parameter 3 + CodeLine : Smallint; // Debug-Zeile + //StatementID : Word; // Debug-Statement ID + End; + + TRutisCode = Array Of TRutisScriptCmd; + PRutisCode = ^TRutisCode; + +{$ENDREGION} + +//==================================================================== +{$REGION 'Rutis-Internal-Types'} +//==================================================================== +//==================================================================== +// Rutis-Internal-Types + +Type + TRutisIntType = ( + intByte, intShortInt, + intWord, intSmallint, + intCardinal, intInteger, + intSingle, intDouble, intExtended, + intBoolean, intPointer, intArray, intRecord, + //intEnum, intSet1, intSet2, intSet4, intSet8, intSetN, + intEnum, intSet, + intShortString, intAChar, intAString, intWChar, intWString, + intMethod, intObjMethod, + intNone); + TRutisIntTypes = Set Of TRutisIntType; + +Const + IntTypeSizes : Array [TRutisIntType] Of Word = + (1, 1, + 2, 2, + 4, 4, + //intSingle, intDouble, intExtended, + 4, 8, 10, + //intBoolean, intPointer, intArray, intRecord, + 1, 4, 4, 0, + //intEnum, intSet, + 1, 4, + //intShortString, intAChar, intAString, intWChar, intWString, + 256, 1, 4, 2, 4, + 4, 8, + 0); + IntTypeAlignSizes : Array [TRutisIntType] Of Word = + (1, 1, + 2, 2, + 4, 4, + //intSingle, intDouble, intExtended, + 4, 8, 16, + //intBoolean, intPointer, intArray, intRecord, + 1, 4, 4, 1, + //intEnum, intSet, + 1, 4, + //intShortString, intAChar, intAString, intWChar, intWString, + 1, 1, 4, 2, 4, + 4, 8, + 1); + + InternalIntegers : TRutisIntTypes = [intByte..intInteger, intEnum]; + InternalFloats : TRutisIntTypes = [intSingle, intDouble, intExtended]; + InternalNumbers : TRutisIntTypes = [intByte..intInteger, intEnum] + [intSingle, intDouble, intExtended]; + + RutisVarTypeTOString : Array [TRutisIntType] Of String = + ('Byte', 'ShortInt', + 'Word', 'Smallint', + 'Cardinal', 'Integer', + 'Single', 'Double', 'Extended', + 'Boolean', 'Pointer', 'Array', 'Record', + 'Enumeration', 'Set', + 'ShortString', 'AnsiChar', 'AnsiString', 'WideChar', 'WideString', + 'Method', 'Method-of-Object', + 'None'); + + RutisTypeConvertTable : Array [TRutisIntType] Of TRutisIntTypes = + ({intByte}[intByte..intExtended, intBoolean, intAChar, intEnum], + {intShortInt}[intByte..intExtended, intBoolean, intAChar, intEnum], + {intWord}[intByte..intExtended, intBoolean, intAChar, intEnum], + {intSmallint}[intByte..intExtended, intBoolean, intAChar, intEnum], + {intCardinal}[intByte..intExtended, intBoolean, intAChar, intMethod, intEnum], + {intInteger}[intByte..intExtended, intBoolean, intAChar, intMethod, intEnum], + //============================= + {intSingle}[intSingle..intExtended], + {intDouble}[intSingle..intExtended], + {intExtended}[intSingle..intExtended], + //============================= + {intBoolean}[intByte..intInteger, intBoolean], + {intPointer}[intCardinal, intInteger, intPointer, intArray, intEnum], + {intArray}[intCardinal, intPointer, intArray], + {intRecord}[], + {intEnum}[intByte..intInteger, intSet], + {intSet}[intByte..intInteger], + {intShortString}[intAString], + {intAChar}[intByte..intInteger, intAString{, intShortString}], + {intAString}[intCardinal, intPointer, intArray, intWString], + {intWChar}[intWord..intInteger, intAString, intWString], + {intWString}[intCardinal, intPointer, intAString], + {intMethod}[intCardinal, intInteger, intPointer], + {intObjMethod}[intCardinal, intInteger, intPointer], + {intNone}[]); + +{$ENDREGION} + +//==================================================================== +{$REGION 'Rutis Stack'} +Type + TRutisStack = Class(TRutisBasicStack) + Public + Function ReadToStr(intType : TRutisIntType; Adr : Integer) : String; + Function ReadToVariant(intType : TRutisIntType; Adr : Integer) : Variant; + Procedure WriteFromVariant(intType : TRutisIntType; Adr : Integer; Val : Variant); + End; + +{$ENDREGION} + +//==================================================================== +{$REGION 'Rutis Declarations'} +//==================================================================== +//==================================================================== +//Rutis Declarations + +Type + TRutisScriptData = Class; + + TRutisDecl = Class + Public + Name : String; + End; + + TRutisDeclArray = Array Of TRutisDecl; + PRutisDeclArray = ^TRutisDeclArray; + + //============================================================================== + + TRutisNamespace = Class(TRutisDecl) + Public + Declarations : TRutisDeclArray; + CodeFile : String; + CodeStart, + CodeEnd : Integer; + Destructor Destroy; Override; + Procedure AddDeclaration(Decl : TRutisDecl); + Function GetDeclaration(AName : String) : TRutisDecl; Overload; + Function GetDeclaration(AName : String; Exclude : Array Of TRutisDecl) : TRutisDecl; Overload; + Function GetDeclarationID(AName : String) : Integer; + End; + + TRutisNamespaceArray = Array Of TRutisNamespace; + PRutisNamespaceArray = ^TRutisNamespaceArray; + + //============================================================================== + + TRutisTypeDecl = Class; + + TRutisTypeDeclClass = Class Of TRutisTypeDecl; + TRutisTypeArray = Array Of TRutisTypeDecl; + + TRutisTypeDecl = Class(TRutisDecl) + Private + Function GetAlignSize : Byte; Virtual; + Public + Size : Word; + ExplicitCast : Boolean; + Function ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; Virtual; + Function GetInternalType : TRutisIntType; Virtual; + Function InternalType : TRutisIntType; + Property AlignSize : Byte Read GetAlignSize; + End; + + //============================================================================== + + TRutisVarDecl = Class(TRutisDecl) + VarType : TRutisTypeDecl; + Address : Integer; + Level : Byte; + isConst : Boolean; + ConstVal : Variant; + End; + + //============================================================================== + TRutisParamInfo = Record + Data : Pointer; + Adr : Integer; + IntType : TRutisIntType; + Size : Word; + End; + PRutisParamInfo = ^TRutisParamInfo; + + TRutisParamInfoArray = Array Of TRutisParamInfo; + PRutisParamInfoArray = ^TRutisParamInfoArray; + + TExtVariMethod = Procedure(Params : PVariantArray; Result : PVariant); + TExtStackMethod = Procedure(Params : PRutisParamInfoArray; Result : PRutisParamInfo); + + //============================================================================== + + TRutisTypeCopy = Class(TRutisTypeDecl) + Public + CopyType : TRutisTypeDecl; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisVarType = Class(TRutisTypeDecl) + Public + IntType : TRutisIntType; + Function GetInternalType : TRutisIntType; Override; + End; + + TEnumVal = Record + Name : String; + Value : Integer; + End; + + TRutisEnumType = Class(TRutisTypeDecl) + Public + Enums : Array Of TEnumVal; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisSetType = Class(TRutisTypeDecl) + Public + EnumType : TRutisEnumType; + Function GetInternalType : TRutisIntType; Override; + Function ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; Override; + End; + + TRutisPointerType = Class(TRutisTypeDecl) + Public + PointerType : TRutisTypeDecl; + Constructor Create; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisArrayType = Class(TRutisTypeDecl) + Public + ArrayType : TRutisTypeDecl; + Constructor Create; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisStructType = Class(TRutisTypeDecl) + Private + Function GetAlignSize : Byte; Override; + Public + StructTypes : Array Of TRutisVarDecl; + IsPacked : Boolean; + fAlignSize : Byte; + Destructor Destroy; Override; + Function GetInternalType : TRutisIntType; Override; + Function ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; Override; + Function VarID(VarName : String) : Integer; + End; + + TRutisClassType = Class(TRutisTypeDecl) + Public + IsExternal : Boolean; + ClassStruct : TRutisStructType; + ParentClass : TRutisClassType; + Constructor Create; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisTypeLink = Record + Name : String; + Size : Word; + InternalType : TRutisIntType; + TypeData : TRutisTypeDecl; + isVarParam : Boolean; + End; + TRutisMethodParamArray = Array Of TRutisTypeLink; + + TRutisMethodType = Class(TRutisTypeDecl) + Public + Method_Name : String; + Description : String; + + IsFunction : Boolean; + Overloaded : Boolean; + Params : TRutisMethodParamArray; + ParamsSize : Word; + MethodResult : TRutisTypeLink; + + Declarations : TRutisDeclArray; + MethodTableID : Integer; + Constructor Create; + Destructor Destroy; Override; + Function GetInternalType : TRutisIntType; Override; + End; + + TRutisExtMethodType = Class(TRutisMethodType) + Public + VariMethod : TExtVariMethod; + StackMethod : TExtStackMethod; + End; + + TRutisDllMethodType = Class(TRutisMethodType) + Public + ProcAddress : Pointer; + DllName : String; + ProcName : String; + End; + +{$ENDREGION} + +//==================================================================== +//==================================================================== + + TIdentType = (itVar, itPVar, itConst, itFixVal, itMethod, itError); + + TAnalyzeIdentInfo = Record + //AllowedIdents : TRutisIntTypes; + TypeData : TRutisTypeDecl; + InternalType : TRutisIntType; + VarDecl : TRutisVarDecl; + Adr, Lvl{, Size} : Integer; + IdentType : TIdentType; + End; + + //==================================================================== + + TRutisCallStackItem = Record + CallLine : Integer; + StackBase : Integer; + Level : Integer; + End; + TRutisCallStack = Array Of TRutisCallStackItem; + + //==================================================================== + + TMemoryRange = Record + Start : PByte; + Size : Integer; + End; + + //==================================================================== + + TRutisErrorType = (etHint, etWarning, etCompilerError, etRuntimeError); + + TErrorProcedure = Procedure(s : String; ErrorType : TRutisErrorType) Of Object; + + //==================================================================== + + TRutisScriptData = Class + Private + Function GetDeclListCount : Integer; + Function GetDeclListItem(Index : Integer) : TRutisDecl; + Procedure SetDeclListItem(Index : Integer; Value : TRutisDecl); + Function IsCompiled : Boolean; + Public + ScriptName : String; + Code : TRutisCode; + Ressources : TRutisStack; + MethodTable : Array Of TRutisMethodType; + //======================== + Running : Boolean; + Paused : Boolean; + Stack : TRutisStack; + CallStack : TRutisCallStack; + AddrRanges : Array Of TMemoryRange; + //======================== + CodeLine : Integer; + CurrCmd : TRutisScriptCmd; + //======================== + CompilerLine : Integer; + CodeInsertPos : Integer; + Namespaces : TRutisNamespaceArray; + //======================== + Constructor Create(StackBlockSize : Cardinal = 1024); + Destructor Destroy; Override; + Procedure Clear; + Procedure FreeExtData; + //======================== + Function GenCodeV(Command : TRutisCmd; Param1, Param2, Param3 : Variant; LineDiff : Integer = 0) : Integer; + Function GenCode(Command : TRutisCmd; Param1, Param2 : Integer; Param3 : Word; LineDiff : Integer = 0) : Integer; + Procedure InsertCodeV(Index : Integer; Command : TRutisCmd; Param1, Param2, Param3 : Variant; LineDiff : Integer = 0); + Procedure InsertCode(Index : Integer; Command : TRutisCmd; Param1, Param2 : Integer; Param3 : Word; LineDiff : Integer = 0); + Procedure DeleteInstruction(index : Integer); + //======================== + Function GetNamespace(Name : String) : TRutisNamespace; + Procedure AddDeclaration(Decl : TRutisDecl; Namespace : String); + Function GetDeclarationID(Name : String; Namespace : String) : Integer; //overload; + Function GetDeclaration(Name : String; Namespace : String) : TRutisDecl; Overload; + Function GetDeclaration(Name : String; Namespace : String; Exclude : Array Of TRutisDecl) : TRutisDecl; Overload; + {Function GetDeclarationID(Name: String): Integer; overload; + Function GetDeclaration(Name: String): TRutisDecl; overload;} + //======================== + Property Compiled : Boolean Read IsCompiled; + Property DeclarationCount : Integer Read GetDeclListCount; + Property DeclarationList[Index : Integer] : TRutisDecl Read GetDeclListItem Write SetDeclListItem; + End; + + PRutisScriptData = ^TRutisScriptData; + + //==================================================================== + //==================================================================== + +{$ifndef FPC} +//Function OutputDebugString(lpDebugStrA : PAnsiChar) : Cardinal; Stdcall; +// External 'kernel32.dll' Name 'OutputDebugStringA'; +{$endif} + + +//============================================================================== +//============================================================================== +{$ifndef FPC} +Function DynamicDllCall(Dll : String; Const Name : String; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; Overload; +Function DynamicDllCall(hDll : THandle; Const Name : String; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; Overload; +Function DynamicDllCall(Proc : Pointer; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; Overload; +{$endif} +//==================================================================== +//==================================================================== +Function SymToStr(Sym : TRutisCmd) : String; +Function StrToSym(Sym : String) : TRutisCmd; +//==================================================================== +Function FindDeclarationID(Name : String; Decl : PRutisDeclArray) : Integer; +Function FindDeclaration(Name : String; Decl : PRutisDeclArray) : TRutisDecl; +//==================================================================== + +//==================================================================== +//==================================================================== +Implementation +//==================================================================== +//==================================================================== + +{$ifndef FPC} +// Calls a function from a library. +// if it's not loaded yet, it will call LoadLibrary() to load it. +Function DynamicDllCall(Dll : String; Const Name : String; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; +Var + Proc : Pointer; + x, n : Integer; + p : Pointer; + hDll : THandle; +Begin + Result := False; + Returned := 0; + //Get Libary + hDll := GetModuleHandle(PChar(Dll)); + If hDll = 0 Then + hDll := LoadLibrary(PChar(Dll)); + If hDll = 0 Then + exit; + //Get Proc-Address + Proc := GetProcAddress(hDll, PChar(Name)); + If not Assigned(Proc) Then + exit; + //Load Parameters + n := High(Parameters); + If n > -1 Then + Begin + x := n; + Repeat + p := Parameters[x]; + Asm + PUSH p + End; + Dec(x); + Until x = -1; + End; + //Call Procedure + Asm + CALL Proc + End; + //Get Result + If HasResult Then + Begin + Asm + MOV p, EAX + End; + Returned := Cardinal(p); + End; + Result := True; +End; +// Calls a function from a loaded library +Function DynamicDllCall(hDll : THandle; Const Name : String; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; +Var + Proc : Pointer; + x, n : Integer; + p : Pointer; +Begin + Result := False; + Returned := 0; + //Get Proc-Address + Proc := GetProcAddress(hDll, PChar(Name)); + If not Assigned(Proc) Then + exit; + //Load Parameters + n := High(Parameters); + If n > -1 Then + Begin + x := n; + Repeat + p := Parameters[x]; + Asm + PUSH p + End; + Dec(x); + Until x = -1; + End; + //Call Procedure + Asm + CALL Proc + End; + //Get Result + If HasResult Then + Begin + Asm + MOV p, EAX + End; + Returned := Cardinal(p); + End; + Result := True; +End; +// Calls a function from a Proc-Address +Function DynamicDllCall(Proc : Pointer; HasResult : Boolean; Var Returned : Cardinal; Const Parameters : Array Of Pointer) : Boolean; +Var + x, n : Integer; + p : Pointer; +Begin + Result := False; + Returned := 0; + //Check Proc-Address + If not Assigned(Proc) Then + exit; + //Load Parameters + n := High(Parameters); + If n > -1 Then + Begin + x := n; + Repeat + p := Parameters[x]; + Asm + PUSH p + End; + Dec(x); + Until x = -1; + End; + //Call Procedure + Asm + CALL Proc + End; + //Get Result + If HasResult Then + Begin + Asm + MOV p, EAX + End; + Returned := Cardinal(p); + End; + Result := True; +End; + +{$endif} + + +//============================================================================== + { ERutisCompilerError } + +Constructor ERutisCompilerError.Create(Msg, Namespace : String); +Begin + Inherited Create(Msg); + ENamespace := Namespace; + ELine := -1; + EChrPos := 0; +End; + +Constructor ERutisCompilerError.Create(Msg, Namespace : String; CLine, CPos : Integer); +Begin + Inherited Create(Msg); + ENamespace := Namespace; + ELine := CLine; + EChrPos := CPos; +End; + +Constructor ERutisCompilerError.CreateFmt(Const Msg : String; Const Args : Array Of Const; Namespace : String); +Begin + Inherited CreateFmt(Msg, Args); + ENamespace := Namespace; + ELine := -1; + EChrPos := 0; +End; + +Constructor ERutisCompilerError.CreateFmt(Const Msg : String; Const Args : Array Of Const; Namespace : String; CLine, CPos : Integer); +Begin + Inherited CreateFmt(Msg, Args); + ENamespace := Namespace; + ELine := CLine; + EChrPos := CPos; +End; + +Procedure ERutisCompilerError.Assign(E : ERutisCompilerError); +Begin + Message := E.Message; + ENamespace := E.ENamespace; + ELine := E.ELine; + EChrPos := E.EChrPos; +End; + +//==================================================================== +{$REGION 'Rutis Declarations'} +//==================================================================== + +//==================================================================== + { TRutisNamespaceDecl } + +Destructor TRutisNamespace.Destroy; +Var + i : Integer; +Begin + For I := 0 To high(Declarations) Do + Declarations[i].Free; + //SetLength(Declarations, 0); + Inherited; +End; + +Procedure TRutisNamespace.AddDeclaration(Decl : TRutisDecl); +Begin + If Decl = nil Then exit; + SetLength(Declarations, Length(Declarations) + 1); + Declarations[high(Declarations)] := Decl; + Decl.Name := UpperCase(Decl.Name); +End; + +Function TRutisNamespace.GetDeclaration(AName : String) : TRutisDecl; +Var i : Integer; +Begin + Result := nil; + AName := UpperCase(AName); + For I := high(Declarations) Downto 0 Do + If Declarations[i].Name = AName Then + Begin + Result := Declarations[i]; + exit; + End; +End; + +Function TRutisNamespace.GetDeclaration(AName : String; Exclude : Array Of TRutisDecl) : TRutisDecl; +Var + i, j : Integer; + Excluded : Boolean; +Begin + Result := nil; + AName := UpperCase(AName); + For I := high(Declarations) Downto 0 Do + If (Declarations[i].Name = AName) Then + Begin + Excluded := False; + For j := 0 To high(Exclude) Do + If Declarations[i] = Exclude[j] Then + Begin + Excluded := True; + break; + End; + If Excluded Then Continue; + Result := Declarations[i]; + exit; + End; +End; + +Function TRutisNamespace.GetDeclarationID(AName : String) : Integer; +Begin + AName := UpperCase(AName); + For Result := high(Declarations) Downto 0 Do + If Declarations[Result].Name = AName Then + exit; + Result := -1; +End; + +//==================================================================== + { TRutisTypeDecl } + +Function TRutisTypeDecl.ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; +Begin + Result := True; + If (WantType = self) Then exit; + If not ExplicitCast Then + Begin + If (WantType.InternalType = InternalType) and not (InternalType in [intRecord]) Then exit; + Result := False; + If not (WantType.InternalType in RutisTypeConvertTable[InternalType]) Then exit; + ScriptData.GenCodeV(_conv, InternalType, WantType.InternalType, 0); + Result := True; + End + Else + Result := False; +End; + +Function TRutisTypeDecl.GetAlignSize : Byte; +Begin + Result := IntTypeAlignSizes[InternalType]; +End; + +Function TRutisTypeDecl.GetInternalType : TRutisIntType; +Begin + Result := intNone; +End; + +Function TRutisTypeDecl.InternalType : TRutisIntType; +Begin + If self = nil Then + Result := intNone + Else + Result := GetInternalType; +End; + +//==================================================================== + { TRutisTypeCopy } + +Function TRutisTypeCopy.GetInternalType : TRutisIntType; +Begin + Result := self.CopyType.InternalType; +End; + +//==================================================================== + { TRutisVarType } + +Function TRutisVarType.GetInternalType : TRutisIntType; +Begin + Result := IntType; +End; + +//============================================================================== + { TRutisEnumType } + +Function TRutisEnumType.GetInternalType : TRutisIntType; +Begin + Result := intEnum; +End; + +//============================================================================== + { TRutisSetType } + +Function TRutisSetType.GetInternalType : TRutisIntType; +Begin + Result := intSet; +End; + +Function TRutisSetType.ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; +Begin + Result := True; + If (WantType = self) Then exit; + If not ExplicitCast Then + Begin + If (WantType.InternalType = InternalType) and + (WantType.Size = Size) Then + exit; + Result := False; + If not (WantType.InternalType in RutisTypeConvertTable[InternalType]) Then exit; + If (WantType.Size <> Size) Then exit; + Case Size Of + 1 : ScriptData.GenCodeV(_conv, intByte, WantType.InternalType, 0); + 2 : ScriptData.GenCodeV(_conv, intWord, WantType.InternalType, 0); + 4 : ScriptData.GenCodeV(_conv, intCardinal, WantType.InternalType, 0); + Else + exit; + End; + Result := True; + End + Else + Result := False; +End; + +//==================================================================== + { TRutisPointerType } + +Constructor TRutisPointerType.Create; +Begin + Size := 4; +End; + +Function TRutisPointerType.GetInternalType : TRutisIntType; +Begin + Result := intPointer; + // Result := PointerType.InternalType; +End; + +//==================================================================== +{ TRutisArrayType } + +Constructor TRutisArrayType.Create; +Begin + Size := 4; +End; + +Function TRutisArrayType.GetInternalType : TRutisIntType; +Begin + Result := intArray; + //Result := ArrayType.InternalType; +End; + +//==================================================================== +{ TRutisStructType } + +Destructor TRutisStructType.Destroy; +Var i : Integer; +Begin + For i := 0 To high(StructTypes) Do + StructTypes[i].Free; + Inherited; +End; + +Function TRutisStructType.GetInternalType : TRutisIntType; +Begin + Result := intRecord; +End; + +Function TRutisStructType.ConvertTo(WantType : TRutisTypeDecl; ScriptData : TRutisScriptData) : Boolean; +Begin + Result := WantType = self; +End; + +Function TRutisStructType.GetAlignSize : Byte; +Begin + Result := fAlignSize; +End; + +Function TRutisStructType.VarID(VarName : String) : Integer; +Begin + VarName := UpperCase(VarName); + For Result := 0 To high(StructTypes) Do + If StructTypes[Result].Name = VarName Then + exit; + Result := -1; +End; + +//============================================================================== + { TRutisClassType } + +Constructor TRutisClassType.Create; +Begin + Size := 4; +End; + +Function TRutisClassType.GetInternalType : TRutisIntType; +Begin + Result := intPointer; +End; + +//==================================================================== + { TRutisMethodType } + +Constructor TRutisMethodType.Create; +Begin + MethodTableID := -1; +End; + +Destructor TRutisMethodType.Destroy; +Var i : Integer; +Begin + For i := 0 To high(Declarations) Do + Declarations[i].Free; + Inherited; +End; + +Function TRutisMethodType.GetInternalType : TRutisIntType; +Begin + Result := intMethod; + //Result := ResultType.InternalType; +End; + +{$ENDREGION} + +//============================================================================== +{$REGION 'Rutis Stack'} +//============================================================================== + +Function TRutisStack.ReadToStr(intType : TRutisIntType; Adr : Integer) : String; +Begin + If Adr >= Top Then + Begin + Result := 'NA'; + exit; + End; + Case intType Of + intByte : Result := IntToStr(ReadByte(Adr)); + intShortInt : Result := IntToStr(ReadShortInt(Adr)); + intWord : Result := IntToStr(ReadWord(Adr)); + intSmallint : Result := IntToStr(ReadSmallint(Adr)); + intCardinal : Result := IntToStr(ReadCardinal(Adr)); + intInteger : Result := IntToStr(ReadInteger(Adr)); + intSingle : Result := FloatToStr(ReadSingle(Adr)); + intDouble : Result := FloatToStr(ReadDouble(Adr)); + intExtended : Result := FloatToStr(ReadExtended(Adr)); + intPointer : Result := IntToHex(ReadCardinal(Adr), 6); + intArray : Result := IntToHex(ReadCardinal(Adr), 6); + intRecord : Result := 'RECORD'; + intEnum : Result := IntToStr(ReadByte(Adr)); + intBoolean : If ReadByte(Adr) = 0 Then + Result := 'false' + Else + Result := 'true'; + intAChar : Result := ReadAChar(Adr); + intAString : + Begin + Try + Result := Ansistring(ReadString(Adr - 4)); + Except + On E : EAccessViolation Do + Begin + If Adr = 0 Then Result := ''; + End; + End; + End; + intMethod : Result := '@' + IntToStr(ReadCardinal(Adr)); + //intMethod : Result := 'METHOD';//Result := '@' + ; + Else + Result := ''; + End; +End; + +Function TRutisStack.ReadToVariant(intType : TRutisIntType; Adr : Integer) : Variant; +Begin + If Adr >= Top Then + Begin + Result := 0; + exit; + End; + Case intType Of + intByte : Result := ReadByte(Adr); + intShortInt : Result := ReadShortInt(Adr); + intWord : Result := ReadWord(Adr); + intSmallint : Result := ReadSmallint(Adr); + intCardinal : Result := ReadCardinal(Adr); + intInteger : Result := ReadInteger(Adr); + intSingle : Result := ReadSingle(Adr); + intDouble : Result := ReadSingle(Adr); + intExtended : Result := ReadSingle(Adr); + intPointer : Result := ReadCardinal(Adr); + //intArray : Result := ReadCardinal(Adr); + intRecord : Result := 0; + intBoolean : Result := Boolean(GetByte(Adr)); + intAString : Result := Ansistring(GetString(Adr)); + intAChar : Result := ReadAChar(Adr); + intWChar : Result := ReadWChar(Adr); + intMethod : Result := 0; + Else + Result := 0; + End; +End; + +Procedure TRutisStack.WriteFromVariant(intType : TRutisIntType; Adr : Integer; Val : Variant); +Begin + If Adr >= Top Then exit; + Case intType Of + intByte : WriteByte(Adr, Val); + intShortInt : WriteShortInt(Adr, Val); + intWord : WriteWord(Adr, Val); + intSmallint : WriteSmallint(Adr, Val); + intCardinal, + intPointer, + intArray : WriteCardinal(Adr, Val); + intInteger : WriteInteger(Adr, Val); + intSingle : WriteSingle(Adr, Val); + intDouble : WriteSingle(Adr, Val); + intExtended : WriteSingle(Adr, Val); + intBoolean : WriteByte(Adr, Val); + intAString : WriteString(Adr, Pointer(Ansistring(Val))); + intAChar : WriteAChar(Adr, AnsiChar(Byte(Val))); + intWChar : WriteWChar(Adr, Widechar(Word(Val))); + End; +End; + +{$ENDREGION} + +//============================================================================== +//============================================================================== + +Function SymToStr(Sym : TRutisCmd) : String; +Begin + Result := cCmd[Sym]; +End; + +Function StrToSym(Sym : String) : TRutisCmd; +Begin + For Result := _gen To _nocmd Do + If cCmd[Result] = Sym Then + exit; + Result := _nocmd; +End; + +//============================================================================== +//============================================================================== + +Function FindDeclarationID(Name : String; Decl : PRutisDeclArray) : Integer; +Begin + Name := UpperCase(Name); + For Result := 0 To high(Decl^) Do + If Decl^[Result].Name = Name Then + exit; + Result := -1; +End; + +Function FindDeclaration(Name : String; Decl : PRutisDeclArray) : TRutisDecl; +Var id : Integer; +Begin + id := FindDeclarationID(Name, Decl); + If id >= 0 Then + Result := Decl^[id] + Else + Result := nil; +End; + +//============================================================================== +//============================================================================== + { TRutisScriptData } + +Constructor TRutisScriptData.Create(StackBlockSize : Cardinal); +Begin + If StackBlockSize < 256 Then StackBlockSize := 256; + Stack := TRutisStack.Create(StackBlockSize); + Ressources := TRutisStack.Create(1024 * 2); +End; + +Destructor TRutisScriptData.Destroy; +Var i : Integer; +Begin + For i := 0 To high(Namespaces) Do + Begin + If Namespaces[i].Name = '$STATIC' Then + SetLength(Namespaces[i].Declarations, 0); + Namespaces[i].Free; + End; + SetLength(Namespaces, 0); + + FreeAndNil(Ressources); + + FreeAndNil(Stack); + + FreeExtData; + + Inherited; +End; + +Procedure TRutisScriptData.Clear; +Var i : Integer; +Begin + For i := 0 To high(Namespaces) Do + Begin + If Namespaces[i].Name = '$STATIC' Then + SetLength(Namespaces[i].Declarations, 0); + Namespaces[i].Free; + End; + SetLength(Namespaces, 0); + + For i := 0 To high(MethodTable) Do + MethodTable[i].MethodTableID := -1; + SetLength(MethodTable, 0); + + SetLength(Code, 0); + + FreeExtData; + If Stack <> nil Then + Stack.Clear; + Try + Ressources.Clear; + Except End; +End; + +Procedure TRutisScriptData.FreeExtData; +Var + i : Integer; +Begin + For i := 0 To high(AddrRanges) Do + FreeMem(AddrRanges[i].Start{, ScriptData.AddrRanges[i].Size}); + SetLength(AddrRanges, 0); +End; + +//============================================================================== + +Function TRutisScriptData.GenCodeV(Command : TRutisCmd; Param1, Param2, Param3 : Variant; LineDiff : Integer = 0) : Integer; +Var + sng : Single; + pp1, pp2 : Integer; +Begin + If VarType(Param1) in [VarSingle, VarDouble] Then + Begin + sng := Param1; + pp1 := PInteger(@sng)^; + End + Else + pp1 := Param1; + + If VarType(Param2) in [VarSingle, VarDouble] Then + Begin + sng := Param2; + pp2 := PInteger(@sng)^; + End + Else + pp2 := Param2; + + Result := GenCode(Command, pp1, pp2, Param3, LineDiff); +End; + +Function TRutisScriptData.GenCode(Command : TRutisCmd; Param1, Param2 : Integer; Param3 : Word; LineDiff : Integer = 0) : Integer; +Var i : Integer; +Begin + SetLength(Code, length(Code) + 1); + If CodeInsertPos > 0 Then + Begin + Result := CodeInsertPos; + Inc(CodeInsertPos); + For I := high(Code) Downto Result + 1 Do + Code[i] := Code[i - 1]; + End + Else + Result := high(Code); + + With Code[Result] Do + Begin + Cmd := Command; + P1 := Param1; + P2 := Param2; + P3 := Param3; + CodeLine := CompilerLine + LineDiff; + //StatementID := CurrStatementID; + End; +End; + +Procedure TRutisScriptData.InsertCodeV(Index : Integer; Command : TRutisCmd; Param1, Param2, Param3 : Variant; LineDiff : Integer = 0); +Var + sng : Single; + pp1, pp2 : Integer; +Begin + If VarType(Param1) in [VarSingle, VarDouble] Then + Begin + sng := Param1; + pp1 := PInteger(@sng)^; + End + Else + pp1 := Param1; + + If VarType(Param2) in [VarSingle, VarDouble] Then + Begin + sng := Param2; + pp2 := PInteger(@sng)^; + End + Else + pp2 := Param2; + + InsertCode(Index, Command, pp1, pp2, Param3, LineDiff); +End; + +Function TRutisScriptData.IsCompiled : Boolean; +Begin + Result := length(Code) > 0; +End; + +Procedure TRutisScriptData.InsertCode(Index : Integer; Command : TRutisCmd; Param1, Param2 : Integer; Param3 : Word; LineDiff : Integer = 0); +Var + i : Integer; +Begin + SetLength(Code, length(Code) + 1); + For I := high(Code) Downto Index + 1 Do + Code[i] := Code[i - 1]; + + For i := Index + 1 To high(Code) Do + If (Code[i].Cmd in [_jmp, _jz, _JL, _jg, _call]) and (Code[i].P1 > index) Then + Inc(Code[i].P1); + + With Code[Index] Do + Begin + Cmd := Command; + P1 := Param1; + P2 := Param2; + P3 := Param3; + CodeLine := CompilerLine + LineDiff; + End; +End; + +Procedure TRutisScriptData.DeleteInstruction(index : Integer); +Var + i, j : Integer; + jpos : PInteger; +Begin + For i := 0 To high(Code) Do + If (Code[i].Cmd in [_jmp, _jz, _JL, _JG, _JLZ, _JGZ, _call]) and (Code[i].P1 > index) Then + Dec(Code[i].P1); + + For i := 0 To high(Namespaces) Do + For j := 0 To high(Namespaces[i].Declarations) Do + If Namespaces[i].Declarations[j] is TRutisVarDecl Then + If TRutisVarDecl(Namespaces[i].Declarations[j]).VarType.ClassType = TRutisMethodType Then + Begin + jpos := Ressources.GetInteger(TRutisVarDecl(Namespaces[i].Declarations[j]).Address); + If (jpos^ > index) Then + jpos^ := jpos^ - 1; + End; + + For i := index To high(Code) - 1 Do + Code[i] := Code[i + 1]; + SetLength(Code, length(Code) - 1); +End; + +//============================================================================== + +Function TRutisScriptData.GetNamespace(Name : String) : TRutisNamespace; +Var i : Integer; +Begin + Result := nil; + Name := UpperCase(Name); + For i := 0 To high(Namespaces) Do + If Namespaces[i].Name = Name Then + Begin + Result := Namespaces[i]; + exit; + End; +End; + +Procedure TRutisScriptData.AddDeclaration(Decl : TRutisDecl; Namespace : String); +Var + Namespacedecl : TRutisNamespace; +Begin + If Decl = nil Then exit; + Namespacedecl := GetNamespace(Namespace); + If Namespacedecl = nil Then + Begin + SetLength(Namespaces, length(Namespaces) + 1); + Namespacedecl := TRutisNamespace.Create; + Namespacedecl.Name := UpperCase(Namespace); + Namespaces[high(Namespaces)] := Namespacedecl; + End; + Namespacedecl.AddDeclaration(Decl); +End; + +Function TRutisScriptData.GetDeclarationID(Name : String; Namespace : String) : Integer; +Var + Namespacedecl : TRutisNamespace; +Begin + Result := -1; + Namespacedecl := GetNamespace(Namespace); + If (Namespacedecl = nil) Then exit; + Result := Namespacedecl.GetDeclarationID(Name); +End; + +Function TRutisScriptData.GetDeclaration(Name : String; Namespace : String) : TRutisDecl; +Var + Namespacedecl : TRutisNamespace; +Begin + Result := nil; + Namespacedecl := GetNamespace(Namespace); + If (Namespacedecl = nil) Then exit; + Result := Namespacedecl.GetDeclaration(Name); +End; + +Function TRutisScriptData.GetDeclaration(Name : String; Namespace : String; Exclude : Array Of TRutisDecl) : TRutisDecl; +Var + Namespacedecl : TRutisNamespace; +Begin + Result := nil; + Namespacedecl := GetNamespace(Namespace); + If (Namespacedecl = nil) Then exit; + Result := Namespacedecl.GetDeclaration(Name, Exclude); +End; + +{ +Function TRutisScriptData.GetDeclarationID(Name: String) : Integer; +var + i : Integer; +Begin + for I := high(Namespaces) downto 0 do + begin + Result := Namespaces[i].GetDeclarationID(Name); + If Result <> -1 then exit; + end; + Result := -1; +End; +Function TRutisScriptData.GetDeclaration(Name: String) : TRutisDecl; +var + i : Integer; +Begin + for I := high(Namespaces) downto 0 do + begin + Result := Namespaces[i].GetDeclaration(Name); + If Result <> nil then exit; + end; + Result := nil; +End; +} +//============================================================================== + +Function TRutisScriptData.GetDeclListCount : Integer; +Var i : Integer; +Begin + Result := 0; + For I := 0 To high(Namespaces) Do + Result := Result + length(Namespaces[i].Declarations); +End; + +Function TRutisScriptData.GetDeclListItem(Index : Integer) : TRutisDecl; +Var i : Integer; +Begin + Result := nil; + If length(Namespaces) = 0 Then exit; + i := 0; + While Index >= length(Namespaces[i].Declarations) Do + Begin + Index := Index - length(Namespaces[i].Declarations); + Inc(i); + If i > high(Namespaces) Then exit; + End; + Result := Namespaces[i].Declarations[Index]; +End; + +Procedure TRutisScriptData.SetDeclListItem(Index : Integer; Value : TRutisDecl); +Var i : Integer; +Begin + If length(Namespaces) = 0 Then exit; + i := 0; + While Index >= length(Namespaces[i].Declarations) Do + Begin + Index := Index - length(Namespaces[i].Declarations); + Inc(i); + If i > high(Namespaces) Then exit; + End; + Namespaces[i].Declarations[Index] := Value; +End; + +//============================================================================== +End. + diff --git a/Units/RUTIS/Rutis_EXT_Canvas.pas b/Units/RUTIS/Rutis_EXT_Canvas.pas new file mode 100644 index 0000000..7cc91a8 --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_Canvas.pas @@ -0,0 +1,429 @@ +Unit Rutis_EXT_Canvas; + +Interface + +Uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + StdCtrls, ComCtrls, ExtCtrls, + Rutis_Stack, Rutis_Engine, Rutis_Defs; + +Type + TUniversalCanvas = Class(TControlCanvas) + Protected + fDCHandle : HWND; + Public + Destructor Destroy; Override; + Procedure ReleaseTarget; + Procedure SetTargetDC(DC : HDC); + Procedure SetTargetHandle(AHandle : HWND); + Procedure SetTargetControl(AControl : TControl); + End; + +Var + RC_Buffer : TBitmap; + RC_DrawCanvas : TCanvas; + RC_TargetCanvas : TCanvas; + RC_DoubleBuffered : Boolean; + RC_Width, + RC_Height : Integer; + RC_BGColor : TColor; + + +Procedure RC_SetTargetDC(DC : HDC); +Procedure RC_SetTargetHandle(Handle : HWND); +Procedure RC_SetTargetCanvas(Canvas : TCanvas); +Procedure RC_SetTargetControl(Control : TControl); +Procedure RC_Repaint; +Procedure RegisterEXTMethods(Engine : TRutisEngine); + +Implementation + +Var + RC_DCCanvas : TUniversalCanvas; + +Type + PControl = ^TControl; + + //============================================================================== + //============================================================================== + { TUniversalCanvas } + +Destructor TUniversalCanvas.Destroy; +Begin + ReleaseTarget; + Inherited; +End; + +Procedure TUniversalCanvas.ReleaseTarget; +Begin + If HandleAllocated Then + Begin + If (fDCHandle <> 0) Then + ReleaseDC(Handle, fDCHandle); + Handle := 0; + fDCHandle := 0; + End; +End; + +Procedure TUniversalCanvas.SetTargetDC(DC : HDC); +Begin + ReleaseTarget; + If DC = 0 Then exit; + Handle := DC; +End; + +Procedure TUniversalCanvas.SetTargetHandle(AHandle : HWND); +Begin + ReleaseTarget; + //If AHandle = 0 then exit; + fDCHandle := AHandle; + Try + Handle := GetDC(fDCHandle); + Except + Handle := 0; + fDCHandle := 0; + End; +End; + +Procedure TUniversalCanvas.SetTargetControl(AControl : TControl); +Begin + ReleaseTarget; + If AControl <> nil Then + Control := AControl; +End; + +//============================================================================== +//============================================================================== + +Procedure RC_SetTargetDC(DC : HDC); +Begin + RC_DCCanvas.SetTargetDC(DC); + RC_TargetCanvas := RC_DCCanvas; + + If RC_DoubleBuffered Then + RC_DrawCanvas := RC_Buffer.Canvas + Else + RC_DrawCanvas := RC_TargetCanvas; +End; + +Procedure RC_SetTargetHandle(Handle : HWND); +Begin + RC_DCCanvas.SetTargetHandle(Handle); + RC_TargetCanvas := RC_DCCanvas; + + If RC_DoubleBuffered Then + RC_DrawCanvas := RC_Buffer.Canvas + Else + RC_DrawCanvas := RC_TargetCanvas; +End; + +Procedure RC_SetTargetControl(Control : TControl); +Begin + If (Control is TImage) Then + Begin + RC_TargetCanvas := TImage(Control).Canvas; + RC_DCCanvas.ReleaseTarget; + End + Else + Begin + RC_DCCanvas.SetTargetControl(Control); + RC_TargetCanvas := RC_DCCanvas; + End; + + If RC_DoubleBuffered Then + RC_DrawCanvas := RC_Buffer.Canvas + Else + RC_DrawCanvas := RC_TargetCanvas; +End; + +Procedure RC_SetTargetCanvas(Canvas : TCanvas); +Begin + RC_DCCanvas.ReleaseTarget; + + RC_TargetCanvas := Canvas; + + If RC_DoubleBuffered Then + RC_DrawCanvas := RC_Buffer.Canvas + Else + RC_DrawCanvas := RC_TargetCanvas; +End; + +Procedure RC_Repaint; +Begin + If RC_DoubleBuffered Then + RC_TargetCanvas.Draw(0, 0, RC_Buffer); +End; + +//============================================================================== +//============================================================================== + +Procedure _CanvasDC(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_SetTargetDC(PCardinal(Params^[0].Data)^); +End; + +Procedure _CanvasHandle(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_SetTargetHandle(PCardinal(Params^[0].Data)^); +End; + +Procedure _CanvasControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_SetTargetControl(PControl(Params^[0].Data)^); +End; + +Procedure _CanvasDoubleBuffered(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DoubleBuffered := PBoolean(Params^[0].Data)^; + If RC_DoubleBuffered Then + RC_DrawCanvas := RC_Buffer.Canvas + Else + RC_DrawCanvas := RC_TargetCanvas; +End; + +Procedure _CanvasClear(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + rect : TRect; + TmpColor : TColor; +Begin +// RC_BGColor := RC_DrawCanvas.Brush.Color; +// If RC_DoubleBuffered Then +// Begin +// //RC_Buffer.Width := 0; +// //RC_Buffer.Width := RC_Width; +// rect := RC_Buffer.Canvas.ClipRect; +// inc(rect.Right); +// inc(rect.Bottom); + +// TmpColor := RC_Buffer.Canvas.Pen.Color; +// RC_Buffer.Canvas.Pen.Color := RC_BGColor; + +// RC_Buffer.Canvas.FillRect(rect); + +// RC_Buffer.Canvas.Pen.Color := TmpColor; +// End +// Else +// Begin +// rect := RC_TargetCanvas.ClipRect; +// inc(rect.Right); +// inc(rect.Bottom); + +// RC_TargetCanvas.Brush.Color := RC_BGColor; +// RC_TargetCanvas.Pen.Color := RC_BGColor; +// RC_TargetCanvas.FillRect(rect); +// End; + + RC_BGColor := RC_DrawCanvas.Brush.Color; + TmpColor := RC_DrawCanvas.Pen.Color; + + rect := RC_DrawCanvas.ClipRect; + Inc(rect.Right); + Inc(rect.Bottom); + + RC_DrawCanvas.Pen.Color := RC_BGColor; + + RC_DrawCanvas.FillRect(rect); + + RC_DrawCanvas.Pen.Color := TmpColor; +End; + +Procedure _CanvasSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + AColor : TColor; +Begin + RC_Width := PInteger(Params^[0].Data)^; + RC_Height := PInteger(Params^[1].Data)^; + //CorrectBufferSize(RC_Width, RC_Height); + If RC_DoubleBuffered Then + With RC_Buffer Do + Begin + AColor := Canvas.Brush.Color; + Canvas.Brush.Color := RC_BGColor; + If (RC_Width <> Width) Then Width := RC_Width; + If (RC_Height <> Height) Then Height := RC_Height; + Canvas.Brush.Color := AColor; + End; +End; + +Procedure _CanvasDisplay(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If RC_DoubleBuffered Then + RC_TargetCanvas.Draw(0, 0, RC_Buffer); +End; + +//============================================================================== + +Procedure _BrushSolid(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Brush.Style := bsSolid; +End; + +Procedure _BrushClear(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Brush.Style := bsClear; +End; + +Procedure _PenColor(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Pen.Color := PColor(Params^[0].Data)^; +End; + +Procedure _BrushColor(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Brush.Color := PColor(Params^[0].Data)^; +End; + +Procedure _PenColorRGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Pen.Color := rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^); +End; + +Procedure _BrushColorRGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Brush.Color := rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^); +End; + +Procedure _PenWidth(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Pen.Width := PInteger(Params^[0].Data)^; +End; + +Procedure _Rectangle(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var x1, y1, x2, y2 : Integer; +Begin + x1 := PInteger(Params^[0].Data)^; + y1 := PInteger(Params^[1].Data)^; + x2 := PInteger(Params^[2].Data)^; + y2 := PInteger(Params^[3].Data)^; + //CorrectBufferSize(Max(x1, x2), Max(y1, y2)); + RC_DrawCanvas.Rectangle(x1, y1, x2, y2); +End; + +Procedure _Ellipse(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var x1, y1, x2, y2 : Integer; +Begin + x1 := PInteger(Params^[0].Data)^; + y1 := PInteger(Params^[1].Data)^; + x2 := PInteger(Params^[2].Data)^; + y2 := PInteger(Params^[3].Data)^; + //CorrectBufferSize(Max(x1, x2), Max(y1, y2)); + RC_DrawCanvas.Ellipse(x1, y1, x2, y2); +End; + +Procedure _MoveTo(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var x1, y1 : Integer; +Begin + x1 := PInteger(Params^[0].Data)^; + y1 := PInteger(Params^[1].Data)^; + //CorrectBufferSize(x1,y1); + RC_DrawCanvas.MoveTo(x1, y1); +End; + +Procedure _LineTo(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var x1, y1 : Integer; +Begin + x1 := PInteger(Params^[0].Data)^; + y1 := PInteger(Params^[1].Data)^; + //CorrectBufferSize(x1,y1); + RC_DrawCanvas.LineTo(x1, y1); +End; + +Procedure _TextOut(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var x1, y1 : Integer; +Begin + x1 := PInteger(Params^[0].Data)^; + y1 := PInteger(Params^[1].Data)^; + With RC_DrawCanvas Do + Begin + //CorrectBufferSize(x1 + TextHeight(Params^[2]), y1 + TextWidth(Params^[2])); + RC_DrawCanvas.Font.Color := RC_DrawCanvas.Pen.Color; + TextOut(x1, y1, PAnsiString(Params^[2].Data)^); + End; +End; + +Procedure _TextSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Font.Size := GetPInteger(Params^[0].Data); +End; + +Procedure _GetPixel(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := Cardinal(RC_DrawCanvas.Pixels[PInteger(Params^[0].Data)^, + PInteger(Params^[1].Data)^]); +End; + +Procedure _SetPixel(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + RC_DrawCanvas.Pixels[PInteger(Params^[0].Data)^, + PInteger(Params^[1].Data)^] := TColor(PCardinal(Params^[2].Data)^); +End; + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Begin + OutputDebugString(PChar('Rutis_EXT_Canvas.RegisterEXTMethods - Registering RUTIS Canvas Support')); + + //============================================================================== + //====================== CANVAS ================================================ + //============================================================================== + + Engine.RegExtMethod('CanvasControl',{$IfDef FPC}@{$EndIf}_CanvasControl, ['TControl'], '', + 'Set the Control for the Canvas'); + Engine.RegExtMethod('CanvasHandle',{$IfDef FPC}@{$EndIf}_CanvasHandle, ['HWND'], '', + 'Set the Handle for the Canvas' + sLineBreak + + 'The needed Device Context will be retrived automatically'); + Engine.RegExtMethod('CanvasDC',{$IfDef FPC}@{$EndIf}_CanvasDC, ['HDC'], '', + 'Set the DeviceContext for the Canvas' + sLineBreak + + 'You need to get the DC with GetDC first' + sLineBreak + + 'CanvasDC should normally not be used - use CanvasHandle instead'); + + Engine.RegExtMethod('CanvasSize',{$IfDef FPC}@{$EndIf}_CanvasSize, ['Integer', 'Integer'], '', + 'Set up the Buffer-Size' + sLineBreak + + 'Only needed when using DoubleBuffered-ON'); + Engine.RegExtMethod('CanvasDisplay',{$IfDef FPC}@{$EndIf}_CanvasDisplay, [], '', + 'Displays the Buffer' + sLineBreak + + 'Only needed when using DoubleBuffered-ON'); + Engine.RegExtMethod('CanvasClear',{$IfDef FPC}@{$EndIf}_CanvasClear, [], '', + 'Clears the painted content'); + Engine.RegExtMethod('CanvasDoubleBuffered',{$IfDef FPC}@{$EndIf}_CanvasDoubleBuffered, ['Boolean'], '', + 'If set, all content will be painted into a separate Buffer' + sLineBreak + + 'You will need to set up the Buffer with CanvasSize and CanvasClear first and' + sLineBreak + + 'you have to call CanvasDisplay to show the painted content'); + + Engine.RegExtMethod('MoveTo',{$IfDef FPC}@{$EndIf}_Moveto, ['Integer', 'Integer'], ''); + Engine.RegExtMethod('LineTo',{$IfDef FPC}@{$EndIf}_Lineto, ['Integer', 'Integer'], ''); + Engine.RegExtMethod('Rectangle',{$IfDef FPC}@{$EndIf}_Rectangle, ['Integer', 'Integer', 'Integer', 'Integer'], ''); + Engine.RegExtMethod('Ellipse',{$IfDef FPC}@{$EndIf}_Ellipse, ['Integer', 'Integer', 'Integer', 'Integer'], ''); + Engine.RegExtMethod('TextOut',{$IfDef FPC}@{$EndIf}_TextOut, ['Integer', 'Integer', 'String'], ''); + Engine.RegExtMethod('TextSize',{$IfDef FPC}@{$EndIf}_TextSize, ['Integer'], ''); + Engine.RegExtMethod('PenColorRGB',{$IfDef FPC}@{$EndIf}_PenColorRGB, ['Byte', 'Byte', 'Byte'], ''); + Engine.RegExtMethod('BrushColorRGB',{$IfDef FPC}@{$EndIf}_BrushColorRGB, ['Byte', 'Byte', 'Byte'], ''); + Engine.RegExtMethod('PenColor',{$IfDef FPC}@{$EndIf}_PenColor, ['Integer'], ''); + Engine.RegExtMethod('BrushColor',{$IfDef FPC}@{$EndIf}_BrushColor, ['Integer'], ''); + Engine.RegExtMethod('BrushSolid',{$IfDef FPC}@{$EndIf}_BrushSolid, [], ''); + Engine.RegExtMethod('BrushClear',{$IfDef FPC}@{$EndIf}_BrushClear, [], ''); + Engine.RegExtMethod('PenWidth',{$IfDef FPC}@{$EndIf}_PenWidth, ['Integer'], ''); + + Engine.RegExtMethod('GetPixel',{$IfDef FPC}@{$EndIf}_GetPixel, ['Integer', 'Integer'], 'Integer'); + Engine.RegExtMethod('SetPixel',{$IfDef FPC}@{$EndIf}_SetPixel, ['Integer', 'Integer', 'Integer'], ''); + + + OutputDebugString(PChar('Rutis_EXT_Canvas.RegisterEXTMethods - Successfully registered RUTIS Canvas Support')); +End; + +//============================================================================== +//============================================================================== + +Initialization + RC_Buffer := TBitmap.Create; + RC_DCCanvas := TUniversalCanvas.Create; + + RC_DoubleBuffered := True; + RC_TargetCanvas := RC_Buffer.Canvas; +Finalization + RC_DCCanvas.Free; + RC_Buffer.Free; +End. + diff --git a/Units/RUTIS/Rutis_EXT_Common.pas b/Units/RUTIS/Rutis_EXT_Common.pas new file mode 100644 index 0000000..a8cbfe6 --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_Common.pas @@ -0,0 +1,603 @@ +Unit Rutis_EXT_Common; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +Uses + Windows, Forms, Math, Dialogs, SysUtils, + Rutis_Stack, Rutis_Defs, Rutis_Classes, TypInfo; + +Type + PObject = ^TObject; + PSearchRec = ^TSearchRec; + PClass = ^TClass; + +Procedure RegisterEXTMethods(Engine : TRutisEngineBase); + +Implementation + +//============================================================================== +//======== Strings +//============================================================================== +{$REGION 'Strings'} + +Procedure _ToStr(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Case Params^[0].IntType Of +// intCardinal : PAnsiString(Result^.Data)^ := IntToStr(GetPCardinal(Params^[0].Data)); +// intInteger : PAnsiString(Result^.Data)^ := IntToStr(GetPInteger(Params^[0].Data)); +// intExtended : PAnsiString(Result^.Data)^ := FloatToStr(GetPExtended(Params^[0].Data)); + + intCardinal : SetPAnsiString(Result^.Data, IntToStr(GetPCardinal(Params^[0].Data))); + intInteger : SetPAnsiString(Result^.Data, IntToStr(GetPInteger(Params^[0].Data))); + intExtended : SetPAnsiString(Result^.Data, FloatToStr(GetPExtended(Params^[0].Data))); + +// intCardinal : PAnsiString(Result^.Data)^ := IntToStr(PCardinal(Params^[0].Data)^); +// intInteger : PAnsiString(Result^.Data)^ := IntToStr(PInteger(Params^[0].Data)^); +// intExtended : PAnsiString(Result^.Data)^ := FloatToStr(PExtended(Params^[0].Data)^); + End; +End; + +Procedure _ToInt(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Try + SetPInteger(Result^.Data, StrToInt(AnsiString(GetPPointer(Params^[0].Data)))); + Except + SetPInteger(Result^.Data, 0); + End; +End; + +Procedure _ToFloat(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Try + SetPExtended(Result^.Data, StrToFloat(AnsiString(GetPPointer(Params^[0].Data)))); + Except + SetPExtended(Result^.Data, 0); + End; +End; + +Procedure _SetDecimalSeparator(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + DecimalSeparator := PAnsiChar(Params^[0].Data)^; +End; + +Procedure _GetDecimalSeparator(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PAnsiChar(Result^.Data)^ := DecimalSeparator; +End; + +Procedure _Chr(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PAnsiChar(Result^.Data)^ := Chr(PByte(Params^[0].Data)^); +End; + +Procedure _Ord(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := Ord(PAnsiChar(Params^[0].Data)^); +End; + +Procedure _UpperCase(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, UpperCase(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +Procedure _LowerCase(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, LowerCase(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +Procedure _StringReplace(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Type PReplaceFlags = ^TReplaceFlags; +Begin + PAnsiString(Result^.Data)^ := StringReplace( + AnsiString(GetPPointer(Params^[0].Data)), + AnsiString(GetPPointer(Params^[1].Data)), + AnsiString(GetPPointer(Params^[2].Data)), + {$ifdef WinCe}unaligned({$endif}PReplaceFlags(Params^[3].Data)^{$ifdef WinCe}){$endif}); +End; + +Procedure _ExtractFilePath(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, ExtractFilePath(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +Procedure _ExtractFileName(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, ExtractFileName(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +Procedure _ExtractFileExt(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, ExtractFileExt(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +Procedure _ExpandFileName(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPAnsiString(Result^.Data, ExpandFileName(AnsiString(GetPPointer(Params^[0].Data)))); +End; + +{$ENDREGION} + +//======== Internal ======== +{$REGION 'Internal'} + +Procedure _InheritsClass(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +var + AObject : TObject; + AClass : TClass; +Begin + AObject := TObject(GetPPointer(Params^[0].Data)); + If AObject = nil then exit; + AClass := TClass(GetPPointer(Params^[1].Data)); + If AClass = nil then exit; + PBoolean(Result^.Data)^ := AObject is AClass; +End; + +{$ENDREGION} + +//======== Files ======== +{$REGION 'Files'} + +Procedure _FileExists(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := FileExists(AnsiString(GetPPointer(Params^[0].Data))); +End; + +Procedure _FindFirst(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPInteger(Result^.Data, FindFirst( + AnsiString(GetPPointer(Params^[0].Data)), + GetPInteger(Params^[1].Data), + PSearchRec(Params^[2].Data)^)); +End; + +Procedure _FindNext(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPInteger(Result^.Data, FindNext(PSearchRec(Params^[0].Data)^)); +End; + +Procedure _FindClose(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + FindClose(PSearchRec(Params^[0].Data)^); +End; + +{$ENDREGION} + +//============================================================================== +//======== Windows +//============================================================================== +{$REGION 'Windows'} + +Procedure _Sleep(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Sleep(GetPInteger(Params^[0].Data)); +End; + +Procedure _Delay(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + GTC : Cardinal; +Begin + GTC := GetTickCount + GetPInteger(Params^[0].Data); + While GTC >= GetTickCount Do + Begin + //Application.ProcessMessages; + sleep(1); + End; +End; + +Procedure _RVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data)); +End; + +Procedure _GVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data)); +End; + +Procedure _BVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data)); +End; + +Procedure _RGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPCardinal(Result^.Data, Cardinal(rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^))); +End; + +{$ifndef FPC} +Procedure _DynCallDLLProc(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Type + TPointerArray = Array Of Pointer; + PPointerArray = ^TPointerArray; +Var + DLLName : PAnsiString; + ProcName : PAnsiString; + ProcParams : TPointerArray; + HasResult : Boolean; + ProcResult : Cardinal; +Begin + DLLName := PAnsiString(Params^[0].Data); + ProcName := PAnsiString(Params^[1].Data); + HasResult := PBoolean(Params^[2].Data)^; + ProcParams := PPointerArray(PPointer(Params^[3].Data))^; + If length(ProcParams) > 100 Then exit; + If not DynamicDllCall(DLLName^, ProcName^, HasResult, ProcResult, ProcParams) Then + Begin + //ShowMessage('Function could not be found!'); + PCardinal(Result^.Data)^ := 0; + End + Else + Begin + PCardinal(Result^.Data)^ := ProcResult; + End; +End; +{$endif} + +Procedure _GetTickCount(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPCardinal(Result^.Data, GetTickCount); +End; + +Procedure _GetAsyncKeyState(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Boolean(GetAsyncKeyState(GetPWord(Params^[0].Data)) <> 0); +End; + +{$ifndef WINCE} +Procedure _Beep(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Windows.Beep(GetPCardinal(Params^[0].Data), GetPCardinal(Params^[1].Data)); +End; +{$endif WINCE} + +Procedure _InputDlg(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + str : AnsiString; + StrOut : Pointer; +Begin + str := AnsiString(GetPPointer(Params^[1].Data)); + If not InputQuery('Input', AnsiString(GetPPointer(Params^[0].Data)), str) Then + SetPAnsiString(Result^.Data, '') + else + SetPAnsiString(Result^.Data, Str); +End; + +{$ENDREGION} + +//============================================================================== +//======== Properties +//============================================================================== +{$REGION 'Properties'} + +Procedure _SetIntProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + SetOrdProp(Obj, PropInfo, GetPInteger(Params^[2].Data)); + Except + End; +End; + +Procedure _GetIntProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + SetPInteger(Result^.Data, GetOrdProp(Obj, PropInfo)); + Except + End; +End; + +Procedure _SetBoolProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + SetOrdProp(Obj, PropInfo, PByte(Params^[2].Data)^); + Except + End; +End; + +Procedure _GetBoolProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + PByte(Result^.Data)^ := GetOrdProp(Obj, PropInfo); + Except + End; +End; + +Procedure _SetStrProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + SetStrProp(Obj, PropInfo, AnsiString(GetPPointer(Params^[2].Data))); + Except + End; +End; + +Procedure _GetStrProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Obj : TObject; + PropInfo : PPropInfo; + PropName : AnsiString; +Begin + Obj := TObject(GetPPointer(Params^[0].Data)); + PropName := AnsiString(GetPPointer(Params^[1].Data)); + Try + PropInfo := GetPropInfo(Obj, PropName); + If PropInfo <> nil Then + SetPAnsiString(Result^.Data, GetStrProp(Obj, PropInfo)); + Except + End; +End; + +{$ENDREGION} + +//============================================================================== +//======== Math +//============================================================================== +{$REGION 'Maths'} + +Procedure _Round(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPInteger(Result^.Data, round(GetPSingle(Params^[0].Data))); +End; + +Procedure _abs(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Case Params^[0].IntType Of + intInteger : SetPInteger(Result^.Data, abs(GetPInteger(Params^[0].Data))); + intSingle : SetPSingle(Result^.Data, abs(GetPSingle(Params^[0].Data))); + intDouble : SetPDouble(Result^.Data, abs(GetPDouble(Params^[0].Data))); + End; +End; + +Procedure _RandomF(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPDouble(Result^.Data, random); +End; + +Procedure _Random(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPInteger(Result^.Data, random(GetPInteger(Params^[0].Data))); +End; + +Procedure _sqr(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var d : Single; +Begin + d := GetPSingle(Params^[0].Data); + SetPSingle(Result^.Data, d * d); +End; + +Procedure _sqrt(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, sqrt(GetPSingle(Params^[0].Data))); +End; + +Procedure _sqrtvari(Params : PVariantArray; Result : PVariant); +Begin + Result^ := sqrt(Params^[0]); +End; + +Procedure _Sin(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, Sin(GetPSingle(Params^[0].Data))); +End; + +Procedure _Cos(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, Cos(GetPSingle(Params^[0].Data))); +End; + +Procedure _ArcSin(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, ArcSin(GetPSingle(Params^[0].Data))); +End; + +Procedure _ArcCos(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, ArcCos(GetPSingle(Params^[0].Data))); +End; + +Procedure _Arctan2(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SetPSingle(Result^.Data, Arctan2(GetPSingle(Params^[0].Data), GetPSingle(Params^[1].Data))); +End; + +{$ENDREGION} + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngineBase); +Begin + //======== Strings ======== + {$REGION 'Strings'} + + Engine.RegExtMethod('IntToStr',{$IfDef FPC}@{$EndIf}_ToStr, ['Integer'], 'String'); + Engine.RegExtMethod('FloatToStr',{$IfDef FPC}@{$EndIf}_ToStr, ['Extended'], 'String'); + Engine.RegExtMethod('StrToInt',{$IfDef FPC}@{$EndIf}_ToInt, ['String'], 'Integer'); + Engine.RegExtMethod('StrToFloat',{$IfDef FPC}@{$EndIf}_ToFloat, ['String'], 'Extended'); + Engine.RegExtMethod('DecimalSeparator',{$IfDef FPC}@{$EndIf}_GetDecimalSeparator, [], 'Char'); + Engine.RegExtMethod('DecimalSeparator',{$IfDef FPC}@{$EndIf}_SetDecimalSeparator, ['Char'], ''); + + Engine.RegExtMethod('Chr',{$IfDef FPC}@{$EndIf}_Chr, ['Byte'], 'AnsiChar'); + Engine.RegExtMethod('Ord',{$IfDef FPC}@{$EndIf}_Ord, ['AnsiChar'], 'Byte'); + Engine.RegExtMethod('UpperCase',{$IfDef FPC}@{$EndIf}_UpperCase, ['AnsiString'], 'AnsiString'); + Engine.RegExtMethod('LowerCase',{$IfDef FPC}@{$EndIf}_LowerCase, ['AnsiString'], 'AnsiString'); + + Engine.RegExtMethod('StringReplace',{$IfDef FPC}@{$EndIf}_LowerCase, ['AnsiString', 'AnsiString', 'AnsiString', 'Cardinal'], 'AnsiString'); + + Engine.RegExtMethod('ExtractFilePath',{$IfDef FPC}@{$EndIf}_ExtractFilePath, ['AnsiString'], 'AnsiString'); + Engine.RegExtMethod('ExtractFileName',{$IfDef FPC}@{$EndIf}_ExtractFileName, ['AnsiString'], 'AnsiString'); + Engine.RegExtMethod('ExtractFileExt',{$IfDef FPC}@{$EndIf}_ExtractFileExt, ['AnsiString'], 'AnsiString'); + Engine.RegExtMethod('ExpandFileName',{$IfDef FPC}@{$EndIf}_ExpandFileName, ['AnsiString'], 'AnsiString'); + + {$ENDREGION} + + //======== Internal ======== + {$REGION 'Internal'} + Engine.RegExtMethod('InheritsClass',{$IfDef FPC}@{$EndIf}_InheritsClass, ['TObject', 'TClass'], 'Boolean'); + {$ENDREGION} + + //======== MATHS ======== + {$REGION 'Maths'} + + Engine.RegExtMethod('Round',{$IfDef FPC}@{$EndIf}_Round, ['Single'], 'Integer'); + Engine.RegExtMethod('abs_int',{$IfDef FPC}@{$EndIf}_abs, ['Integer'], 'Integer', + 'Makes an integer value positive'); + Engine.RegExtMethod('abs',{$IfDef FPC}@{$EndIf}_abs, ['Double'], 'Double', + 'Makes a float value positive'); + + Engine.RegExtMethod('RandomF',{$IfDef FPC}@{$EndIf}_RandomF, [], 'Double', + 'Returns a random float value in the Intervall [0..1]'); + Engine.RegExtMethod('Random',{$IfDef FPC}@{$EndIf}_Random, ['Integer'], 'Integer', + 'Returns a random Integer number in the Intervall [0..a-1]'); + + Engine.RegExtMethod('sin',{$IfDef FPC}@{$EndIf}_sin, ['Single'], 'Single'); + Engine.RegExtMethod('cos',{$IfDef FPC}@{$EndIf}_cos, ['Single'], 'Single'); + Engine.RegExtMethod('Arcsin',{$IfDef FPC}@{$EndIf}_Arcsin, ['Single'], 'Single'); + Engine.RegExtMethod('Arccos',{$IfDef FPC}@{$EndIf}_Arccos, ['Single'], 'Single'); + Engine.RegExtMethod('Arctan2',{$IfDef FPC}@{$EndIf}_Arctan2, ['Single', 'Single'], 'Single', + 'Returns the Angle of an triangle with the two given sides'); + + Engine.RegExtMethod('sqr',{$IfDef FPC}@{$EndIf}_sqr, ['Single'], 'Single'); + Engine.RegExtMethod('sqrt',{$IfDef FPC}@{$EndIf}_sqrt, ['Single'], 'Single', + 'Returns the squareroot of the value'); + Engine.RegExtMethodV('sqrtvari',{$IfDef FPC}@{$EndIf}_sqrtvari, ['Single'], 'Single', + 'for testing only'); + + {$ENDREGION} + + //======== Properties ======== + {$REGION 'Properties'} + + Engine.RegExtMethod('SetIntProperty',{$IfDef FPC}@{$EndIf}_SetIntProperty, ['TObject', 'String', 'Integer'], '', + 'Sets the (Integer) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + '#3 : New Value for Property'); + Engine.RegExtMethod('GetIntProperty',{$IfDef FPC}@{$EndIf}_GetIntProperty, ['TObject', 'String'], 'Integer', + 'Returns the (Integer) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + 'Returns : Value of Property'); + + Engine.RegExtMethod('SetStrProperty',{$IfDef FPC}@{$EndIf}_SetStrProperty, ['TObject', 'String', 'String'], '', + 'Sets the (String) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + '#3 : New Value for Property'); + Engine.RegExtMethod('GetStrProperty',{$IfDef FPC}@{$EndIf}_GetStrProperty, ['TObject', 'String'], 'String', + 'Returns the (String) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + 'Returns : Value of Property'); + + Engine.RegExtMethod('SetBoolProperty',{$IfDef FPC}@{$EndIf}_SetBoolProperty, ['TObject', 'String', 'Boolean'], '', + 'Sets the (Boolean) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + '#3 : New Value for Property'); + Engine.RegExtMethod('GetBoolProperty',{$IfDef FPC}@{$EndIf}_GetBoolProperty, ['TObject', 'String'], 'Boolean', + 'Returns the (Boolean) property value for an Object' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Property-Name' + sLineBreak + + 'Returns : Value of Property'); + + {$ENDREGION} + + //======== Files ======== + {$REGION 'Files'} + + Engine.RegExtMethod('FileExists',{$IfDef FPC}@{$EndIf}_FileExists, ['AnsiString'], 'Boolean'); + Engine.RegExtMethod('FindFirst',{$IfDef FPC}@{$EndIf}_FindFirst, ['AnsiString', 'Integer', 'PSearchRec'], 'Integer'); + Engine.RegExtMethod('FindNext',{$IfDef FPC}@{$EndIf}_FindNext, ['PSearchRec'], 'Integer'); + Engine.RegExtMethod('FindClose',{$IfDef FPC}@{$EndIf}_FindClose, ['PSearchRec'], ''); + + {$ENDREGION} + + //======== Windows ======== + {$REGION 'Windows'} + + {$ifndef FPC} + Engine.RegExtMethod('CallDLLProc',{$IfDef FPC}@{$EndIf}_DynCallDLLProc, ['String', 'String', 'Boolean', 'Pointer'], 'Cardinal', + 'Executes a DLL Method'); + {$endif} + + Engine.RegExtMethod('GetAsyncKeyState',{$IfDef FPC}@{$EndIf}_GetAsyncKeyState, ['Word'], 'Boolean', + 'Checks whether a certain key is pressed' + sLineBreak + 'Returns true, if the key was pressed since the last call of GetAsyncKeyState for this key'); + + Engine.RegExtMethod('GetTickCount',{$IfDef FPC}@{$EndIf}_GetTickCount, [], 'Cardinal', + 'Returns the current System-Time in milli-seconds'); + + {$ifndef WINCE} + Engine.RegExtMethod('Beep',{$IfDef FPC}@{$EndIf}_Beep, ['Cardinal', 'Cardinal'], ''); + {$endif WINCE} + + Engine.RegExtMethod('Sleep',{$IfDef FPC}@{$EndIf}_Sleep, ['Integer'], ''); + Engine.RegExtMethod('Delay',{$IfDef FPC}@{$EndIf}_Delay, ['Integer'], '', + 'Delays the execution of the script for a certain time'); + + Engine.RegExtMethod('InputDlg',{$IfDef FPC}@{$EndIf}_InputDlg, ['String', 'String'], 'String', + 'Shows an Input-Dialog for the user' + sLineBreak + + '#1: Question' + sLineBreak + + '#2: Default value' + sLineBreak + + 'Returns the string the user has entered or '' if the' + sLineBreak + 'user has pressed the Cancel-Button'); + + Engine.RegExtMethod('RVal',{$IfDef FPC}@{$EndIf}_RVal, ['Cardinal'], 'Byte', + 'Extracts the Red-Component of a TColor value'); + Engine.RegExtMethod('GVal',{$IfDef FPC}@{$EndIf}_GVal, ['Cardinal'], 'Byte', + 'Extracts the Green-Component of a TColor value'); + Engine.RegExtMethod('BVal',{$IfDef FPC}@{$EndIf}_BVal, ['Cardinal'], 'Byte', + 'Extracts the Blue-Component of a TColor value'); + Engine.RegExtMethod('RGB',{$IfDef FPC}@{$EndIf}_RGB, ['Byte', 'Byte', 'Byte'], 'Cardinal', + 'Creates a TColor Value out of the red, green and blue components'); + + {$ENDREGION} +End; + +Initialization + randomize; +End. + diff --git a/Units/RUTIS/Rutis_EXT_Dialogs.pas b/Units/RUTIS/Rutis_EXT_Dialogs.pas new file mode 100644 index 0000000..77fbe61 --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_Dialogs.pas @@ -0,0 +1,126 @@ +Unit Rutis_EXT_Dialogs; + +{$mode objfpc}{$H+} + +Interface + +Uses + Classes, SysUtils, + Rutis_Defs, + {$IfDef WinCE}WinCE_FileDialog,{$EndIf WinCE} + Dialogs; + +Procedure RegisterEXTMethods(MethodList : PExtMethodList); + +Implementation + +Procedure _OpenFileDialog(Stack : PRutisStack; Param0 : Integer; Result : PRutisStackItem); +Var + {$IfDef WinCE} + dlg : TFFileDialog; + {$Else WinCE} + dlg : TOpenDialog; + {$EndIf WinCE} +Begin + MakeVType(@Stack^[Param0], VString); + MakeVType(@Stack^[Param0 + 1], VString); + + Result^.VTyp := VString; + New(Result^.VString); + + {$IfDef WinCE} + dlg := TFFileDialog.Create(nil); + try + dlg.FileName := Stack^[Param0].VString^; + dlg.ACaption := 'Open File'; + dlg.Filter := Stack^[Param0+1].VString^; + If dlg.Filter = '' then + dlg.Filter := 'All Files (*.*)|*.*'; + If dlg.Execute then + Result^.VString^ := dlg.FileName + else + Result^.VString^ := ''; + finally + dlg.Free; + end; + + {$Else WinCE} + + dlg := TOpenDialog.Create(nil); + Try + dlg.FileName := Stack^[Param0].VString^; + dlg.Filter := Stack^[Param0 + 1].VString^; + If dlg.Filter = '' Then + dlg.Filter := 'All Files (*.*)|*.*'; + If dlg.Execute Then + Result^.VString^ := dlg.FileName + Else + Result^.VString^ := ''; + Finally + dlg.Free; + End; + + {$EndIf WinCE} +End; + +Procedure _SaveFileDialog(Stack : PRutisStack; Param0 : Integer; Result : PRutisStackItem); +Var + {$IfDef WinCE} + dlg: TFFileDialog; + {$Else WinCE} + dlg : TSaveDialog; + {$EndIf WinCE} +Begin + MakeVType(@Stack^[Param0], VString); + MakeVType(@Stack^[Param0 + 1], VString); + + Result^.VTyp := VString; + New(Result^.VString); + {$IfDef WinCE} + dlg := TFFileDialog.Create(nil); + try + dlg.FileName := Stack^[Param0].VString^; + dlg.ACaption := 'Open File'; + dlg.Filter := Stack^[Param0+1].VString^; + If dlg.Filter = '' then + dlg.Filter := 'All Files (*.*)|*.*'; + If dlg.Execute then + Result^.VString^ := dlg.FileName + else + Result^.VString^ := ''; + finally + dlg.Free; + end; + + {$Else WinCE} + + dlg := TOpenDialog.Create(nil); + Try + dlg.FileName := Stack^[Param0].VString^; + dlg.Filter := Stack^[Param0 + 1].VString^; + If dlg.Filter = '' Then + dlg.Filter := 'All Files (*.*)|*.*'; + If dlg.Execute Then + Result^.VString^ := dlg.FileName + Else + Result^.VString^ := ''; + Finally + dlg.Free; + End; + + {$EndIf WinCE} +End; + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(MethodList : PExtMethodList); +Begin + RegExtMethod('OpenFileDialog',{$IfDef FPC}@{$EndIf}_OpenFileDialog, + [VString, VString], VString, MethodList); + RegExtMethod('SaveFileDialog',{$IfDef FPC}@{$EndIf}_SaveFileDialog, + [VString, VString], VString, MethodList); +End; + +End. + diff --git a/Units/RUTIS/Rutis_EXT_Files.pas b/Units/RUTIS/Rutis_EXT_Files.pas new file mode 100644 index 0000000..dceafba --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_Files.pas @@ -0,0 +1,253 @@ +Unit Rutis_EXT_Files; + +{$ifdef FPC} + {$mode objfpc} + {$H+} +{$endif} + +Interface + +Uses + Windows, Classes, SysUtils, + Rutis_Defs, Rutis_Classes, Rutis_Engine; + +Procedure REFiles_CloseFiles; +Procedure RegisterEXTMethods(Engine : TRutisEngine); + +//============================================================================== +Implementation +//============================================================================== + +Type + PObject = ^TObject; + PFileStream = ^TFileStream; + +Var + REFiles_Streams : Array Of TFileStream; + +//============================================================================== + +Procedure REFiles_CloseFiles; +Var i : Integer; +Begin + For i := 0 To high(REFiles_Streams) Do + REFiles_Streams[i].Free; + SetLength(REFiles_Streams, 0); +End; + +//============================================================================== +//============================================================================== + +Procedure _StreamCreate(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PPointer(Result^.Data)^ := nil; + SetLength(REFiles_Streams, length(REFiles_Streams) + 1); + Try + REFiles_Streams[high(REFiles_Streams)] := TFileStream.Create(PAnsiString(Params^[0].Data)^, PWord(Params^[1].Data)^); //fmCreate or fmShareDenyWrite + Except + REFiles_Streams[high(REFiles_Streams)].Free; + SetLength(REFiles_Streams, length(REFiles_Streams) - 1); + exit; + End; + PPointer(Result^.Data)^ := REFiles_Streams[high(REFiles_Streams)]; +End; + +Procedure _StreamClose(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var i : Integer; +Begin + For i := 0 To high(REFiles_Streams) Do + If REFiles_Streams[i] = PPointer(Params^[0].Data)^ Then + Begin + REFiles_Streams[i].Free; + REFiles_Streams[i] := REFiles_Streams[high(REFiles_Streams)]; + SetLength(REFiles_Streams, length(REFiles_Streams) - 1); + exit; + End; +End; + +Procedure _StreamGetPosition(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PCardinal(Result^.Data)^ := PFileStream(Params^[0].Data)^.Position; +End; + +Procedure _StreamSetPosition(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Position := PCardinal(Params^[1].Data)^; +End; + +Procedure _StreamGetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PCardinal(Result^.Data)^ := PFileStream(Params^[0].Data)^.Size; +End; + +Procedure _StreamSetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Size := PCardinal(Params^[1].Data)^; +End; + +//============================================================================== + +Procedure _StreamWriteByte(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Write(PByte(Params^[1].Data)^, 1); + + PBoolean(Result^.Data)^ := True; +End; + +Procedure _StreamWriteWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Write(PWord(Params^[1].Data)^, 2); + + PBoolean(Result^.Data)^ := True; +End; + +Procedure _StreamWriteDWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Write(PCardinal(Params^[1].Data)^, 4); + + PBoolean(Result^.Data)^ := True; +End; + +Procedure _StreamWriteSingle(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Write(PCardinal(Params^[1].Data)^, 4); + + PBoolean(Result^.Data)^ := True; +End; + +Procedure _StreamWriteString(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + str : Ansistring; +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + str := PAnsiString(Params^[1].Data)^; + StreamWriteString(str, PFileStream(Params^[0].Data)^); + + PBoolean(Result^.Data)^ := True; +End; + +Procedure _StreamWrite(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := False; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Write(PPChar(Params^[1].Data)^^, PInteger(Params^[2].Data)^); + + PBoolean(Result^.Data)^ := True; +End; + +//============================================================================== + +Procedure _StreamReadByte(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Read(PByte(Result^.Data)^, 1); +End; + +Procedure _StreamReadWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PWord(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Read(PWord(Result^.Data)^, 2); +End; + +Procedure _StreamReadDWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PInteger(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Read(PInteger(Result^.Data)^, 4); +End; + +Procedure _StreamReadString(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PAnsiString(Result^.Data)^ := ''; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PAnsiString(Result^.Data)^ := StreamReadString(PFileStream(Params^[0].Data)^); +End; + +Procedure _StreamRead(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PByte(Result^.Data)^ := 0; + If PObject(Params^[0].Data)^ = nil Then exit; + If not (PObject(Params^[0].Data)^ is TFileStream) Then exit; + + PFileStream(Params^[0].Data)^.Read(PPChar(Params^[1].Data)^^, PInteger(Params^[2].Data)^); +End; + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Begin + Engine.RegExtMethod('StreamCreate',{$IfDef FPC}@{$EndIf}_StreamCreate, ['String', 'Word'], 'Pointer'); + Engine.RegExtMethod('StreamClose',{$IfDef FPC}@{$EndIf}_StreamClose, ['Pointer'], 'Pointer'); + Engine.RegExtMethod('StreamGetPosition',{$IfDef FPC}@{$EndIf}_StreamGetPosition, ['Pointer'], 'Cardinal'); + Engine.RegExtMethod('StreamSetPosition',{$IfDef FPC}@{$EndIf}_StreamSetPosition, ['Pointer', 'Cardinal'], ''); + Engine.RegExtMethod('StreamGetSize',{$IfDef FPC}@{$EndIf}_StreamGetSize, ['Pointer'], 'Cardinal'); + Engine.RegExtMethod('StreamSetSize',{$IfDef FPC}@{$EndIf}_StreamSetSize, ['Pointer', 'Cardinal'], ''); + + Engine.RegExtMethod('StreamWriteByte',{$IfDef FPC}@{$EndIf}_StreamWriteByte, ['Pointer', 'Byte'], 'Boolean'); + Engine.RegExtMethod('StreamWriteWord',{$IfDef FPC}@{$EndIf}_StreamWriteWord, ['Pointer', 'Word'], 'Boolean'); + Engine.RegExtMethod('StreamWriteInteger',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Integer'], 'Boolean'); + Engine.RegExtMethod('StreamWriteCardinal',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Cardinal'], 'Boolean'); + Engine.RegExtMethod('StreamWriteSingle',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Single'], 'Boolean'); + Engine.RegExtMethod('StreamWriteString',{$IfDef FPC}@{$EndIf}_StreamWriteString, ['Pointer', 'String'], 'Boolean'); + Engine.RegExtMethod('StreamWrite',{$IfDef FPC}@{$EndIf}_StreamWrite, ['Pointer', 'Pointer', 'Integer'], 'Boolean'); + + Engine.RegExtMethod('StreamReadByte',{$IfDef FPC}@{$EndIf}_StreamReadByte, ['Pointer'], 'Byte'); + Engine.RegExtMethod('StreamReadWord',{$IfDef FPC}@{$EndIf}_StreamReadWord, ['Pointer'], 'Word'); + Engine.RegExtMethod('StreamReadInteger',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Integer'); + Engine.RegExtMethod('StreamReadCardinal',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Cardinal'); + Engine.RegExtMethod('StreamReadSingle',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Single'); + Engine.RegExtMethod('StreamReadString',{$IfDef FPC}@{$EndIf}_StreamReadString, ['Pointer'], 'String'); + Engine.RegExtMethod('StreamRead',{$IfDef FPC}@{$EndIf}_StreamRead, ['Pointer', 'Pointer', 'Integer'], 'Boolean'); +End; + +Initialization +Finalization + REFiles_CloseFiles; +End. + diff --git a/Units/RUTIS/Rutis_EXT_Forms.pas b/Units/RUTIS/Rutis_EXT_Forms.pas new file mode 100644 index 0000000..6c8df32 --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_Forms.pas @@ -0,0 +1,753 @@ +Unit Rutis_EXT_Forms; + +Interface + +Uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + StdCtrls, ComCtrls, ExtCtrls, TypInfo, + Rutis_Engine, Rutis_Defs; + +Type + TUnownedForm = Class(TForm) + Protected + Procedure CreateWnd; Override; + End; + + TEXTF_EventType = ( + etClick, etChange, etResize, etTimer, + etMouseDown, etMouseUp, etMouseMove, + etKeyPress, etKeyDown, etKeyUp, + etNone); +Const + EventNames : Array [TEXTF_EventType] Of String[64] = ( + 'OnClick', 'OnChange', 'OnResize', 'OnTimer', + 'OnMouseDown', 'OnMouseUp', 'OnMouseMove', + 'OnKeyPress', 'OnKeyDown', 'OnKeyUp', + ''); + +Type + TEXTF_EventLink = Record + EventType : TEXTF_EventType; + Control : TControl; + Address : Cardinal; + DoCall : Boolean; + End; + + PControl = ^TControl; + PComponent = ^TComponent; + + TEventContentHolder = Class + Public + ASender : TObject; + AButton : TMouseButton; + AShift : TShiftState; + AX, AY : Integer; + AKey : Word; + Procedure OnClick(Sender : TObject); + Procedure OnTimer(Sender : TObject); + Procedure OnChange(Sender : TObject); + Procedure OnResize(Sender : TObject); + Procedure OnMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + Procedure OnMouseUp(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + Procedure OnMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer); + Procedure OnKeyPress(Sender : TObject; Var Key : Char); + Procedure OnKeyDown(Sender : TObject; Var Key : Word; Shift : TShiftState); + Procedure OnKeyUp(Sender : TObject; Var Key : Word; Shift : TShiftState); + End; + +Var + EXTF_Forms : Array Of TForm; + EXTF_EventLinks : Array Of TEXTF_EventLink; + EXTF_Engine : TRutisEngine; + +Const + ControlClasses : Array [1..11] Of TControlClass = ( + TButton, TLabel, TEdit, TPanel, TMemo, TImage, + TListBox, TCheckBox, TRadioButton, TComboBox, TScrollBar + ); + ComponentClasses : Array [1..1] Of TComponentClass = ( + TTimer + ); + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Procedure EXTF_DestroyRutisForms; +Function EXTF_GetEventID(EventType : TEXTF_EventType; Control : TControl) : Integer; +//============================================================================== +//============================================================================== +Implementation + +Var + EventContentHolder : TEventContentHolder; + EXTF_CurrentForm : TForm; + EXTF_CurrentControl : TControl; + //============================================================================== + //============================================================================== + { TUnownedForm } + +Procedure TUnownedForm.CreateWnd; +Var + Params : TCreateParams; + TempClass : TWndClass; + ClassRegistered : Boolean; +Begin + CreateParams(Params); + With Params Do + Begin + WndParent := 0; + DefWndProc := WindowClass.lpfnWndProc; + ClassRegistered := GetClassInfo(WindowClass.hInstance, WinClassName, TempClass); + If not ClassRegistered or (TempClass.lpfnWndProc <> @InitWndProc) Then + Begin + If ClassRegistered Then Windows.UnregisterClass(WinClassName, + WindowClass.hInstance); + WindowClass.lpfnWndProc := @InitWndProc; + WindowClass.lpszClassName := WinClassName; + If Windows.RegisterClass(WindowClass) = 0 Then RaiseLastOSError; + End; + CreationControl := Self; + CreateWindowHandle(Params); + If WindowHandle = 0 Then + RaiseLastOSError; + If (GetWindowLong(WindowHandle, GWL_STYLE) and WS_CHILD <> 0) and + (GetWindowLong(WindowHandle, GWL_ID) = 0) Then + SetWindowLong(WindowHandle, GWL_ID, WindowHandle); + End; + StrDispose(WindowText); + WindowText := nil; + UpdateBounds; + Perform(WM_SETFONT, Font.Handle, 1); + If AutoSize Then AdjustSize; +End; + +//============================================================================== +//============================================================================== + +Procedure EXTF_DestroyRutisForms; +Var i : Integer; +Begin + For I := 0 To high(EXTF_Forms) Do + EXTF_Forms[i].Free; + SetLength(EXTF_Forms, 0); + SetLength(EXTF_EventLinks, 0); +End; + +Function EXTF_GetEventID(EventType : TEXTF_EventType; Control : TControl) : Integer; +Begin + For Result := 0 To high(EXTF_EventLinks) Do + If (EXTF_EventLinks[Result].EventType = EventType) and + (EXTF_EventLinks[Result].Control = Control) Then + exit; + Result := -1; +End; + +Function EXTF_CallEvents : Boolean; +Var + i : Integer; + CMD : TRutisScriptCmd; +Begin + Result := False; + For i := 0 To high(EXTF_EventLinks) Do + If EXTF_EventLinks[i].DoCall Then + Begin + Result := True; + EXTF_EventLinks[i].DoCall := False; + + {CMD.Cmd := _Gen4; + CMD.P1 := EXTF_EventLinks[i].Address; + CMD.P2 := 0; + CMD.P3 := 0; + EXTF_Engine.ExecuteCMD(CMD);} + + CMD.Cmd := _Call; + CMD.P1 := EXTF_EventLinks[i].Address; + CMD.P2 := 1; + CMD.P3 := 0; + EXTF_Engine.ExecuteCMD(CMD); + End; +End; + +Procedure RegisterObjectEvent(Obj : TObject; EventName : String; Adr : Pointer); +Var + PropInfo : PPropInfo; + AMethod : TMethod; +Begin + AMethod.Code := Adr; + AMethod.Data := EventContentHolder; + Try + PropInfo := GetPropInfo(Obj, EventName); + If PropInfo <> nil Then + SetMethodProp(Obj, PropInfo, AMethod); + Except + End; +End; + +//============================================================================== +//============================================================================== + +//TEXTF_EventType = (etClick, etMouseDown, etMouseUp, etChange, etKeyPress, etKeyDown, etKeyUp); +Procedure TEventContentHolder.OnChange(Sender : TObject); +Var id : Integer; +Begin + ASender := Sender; + id := EXTF_GetEventID(etChange, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +procedure TEventContentHolder.OnTimer(Sender: TObject); +Var id : Integer; +Begin + ASender := Sender; + id := EXTF_GetEventID(etTimer, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +end; + +Procedure TEventContentHolder.OnClick(Sender : TObject); +Var id : Integer; +Begin + ASender := Sender; + id := EXTF_GetEventID(etClick, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnResize(Sender : TObject); +Var id : Integer; +Begin + ASender := Sender; + id := EXTF_GetEventID(etResize, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +Var id : Integer; +Begin + ASender := Sender; + AButton := Button; + AShift := Shift; + AX := X; + AY := Y; + id := EXTF_GetEventID(etMouseDown, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnMouseUp(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +Var id : Integer; +Begin + ASender := Sender; + AButton := Button; + AShift := Shift; + AX := X; + AY := Y; + id := EXTF_GetEventID(etMouseUp, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer); +Var id : Integer; +Begin + ASender := Sender; + AShift := Shift; + AX := X; + AY := Y; + id := EXTF_GetEventID(etMouseMove, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnKeyPress(Sender : TObject; Var Key : Char); +Var id : Integer; +Begin + ASender := Sender; + AKey := Word(Key); + id := EXTF_GetEventID(etKeyPress, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnKeyDown(Sender : TObject; Var Key : Word; Shift : TShiftState); +Var id : Integer; +Begin + ASender := Sender; + AKey := Key; + AShift := Shift; + id := EXTF_GetEventID(etKeyDown, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +Procedure TEventContentHolder.OnKeyUp(Sender : TObject; Var Key : Word; Shift : TShiftState); +Var id : Integer; +Begin + ASender := Sender; + AKey := Key; + AShift := Shift; + id := EXTF_GetEventID(etKeyUp, TControl(Sender)); + If id > -1 Then + EXTF_EventLinks[id].DoCall := True; +End; + +//============================================================================== +//============================================================================== + +Procedure _CreateForm(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Form : TForm; +Begin + Form := TUnownedForm.CreateNew(nil); + + Form.Hide; + Form.Caption := 'RUTIS Formular'; + Form.BorderStyle := bsSizeable; + Form.Position := poScreenCenter; + If PBoolean(Params^[0].Data)^ Then + Form.Show; + + EXTF_CurrentForm := Form; + EXTF_CurrentControl := EXTF_CurrentForm; + + SetLength(EXTF_Forms, length(EXTF_Forms) + 1); + EXTF_Forms[high(EXTF_Forms)] := Form; + + PPointer(Result^.Data)^ := Form; +End; + +Procedure _CreateControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + ClassName : String; + Control : TControl; + ControlParent : TControl; + i : Integer; +Begin + Control := nil; + PControl(Result^.Data)^ := Control; + ClassName := LowerCase(PAnsiString(Params^[1].Data)^); + ControlParent := PControl(Params^[0].Data)^; + If ControlParent = nil Then ControlParent := EXTF_CurrentControl; + + For I := Low(ControlClasses) To high(ControlClasses) Do + If ClassName = LowerCase(ControlClasses[i].ClassName) Then + Control := ControlClasses[i].Create(ControlParent); + If Control = nil Then exit; + + While not (ControlParent is TWinControl) Do + ControlParent := ControlParent.Parent; + Control.Parent := TWinControl(ControlParent); + + PControl(Result^.Data)^ := Control; +End; + +Procedure _CreateComponent(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + ClassName : String; + Component : TComponent; + ComponentParent : TControl; + i : Integer; +Begin + Component := nil; + PComponent(Result^.Data)^ := nil; + ClassName := LowerCase(PAnsiString(Params^[1].Data)^); + ComponentParent := PControl(Params^[0].Data)^; + If ComponentParent = nil Then ComponentParent := EXTF_CurrentControl; + + For I := Low(ComponentClasses) To high(ComponentClasses) Do + If ClassName = LowerCase(ComponentClasses[i].ClassName) Then + Component := ComponentClasses[i].Create(ComponentParent); + If Component = nil Then exit; + + PComponent(Result^.Data)^ := Component; +End; + +Procedure _DestroyControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + i : Integer; + Control : TControl; +Begin + Control := TControl(PPointer(Params^[0].Data)^); + For I := 0 To high(EXTF_Forms) Do + If EXTF_Forms[i] = Control Then + Begin + EXTF_Forms[i] := EXTF_Forms[high(EXTF_Forms)]; + SetLength(EXTF_Forms, length(EXTF_Forms) - 1); + break; + End; + Control.Free; +End; + +Procedure _RegisterEvent(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + EName : String; + EType : TEXTF_EventType; + Crtl : TControl; + I : Integer; +Begin + Crtl := PControl(Params^[0].Data)^; + EName := LowerCase(PAnsiString(Params^[1].Data)^); + + For EType := TEXTF_EventType(0) To etNone Do + If LowerCase(EventNames[EType]) = EName Then + break; + If EType = etNone Then exit; + + RegisterObjectEvent(Crtl, 'Onclick', @TEventCOntentHolder.Onclick); + RegisterObjectEvent(Crtl, 'OnChange', @TEventCOntentHolder.OnChange); + RegisterObjectEvent(Crtl, 'OnResize', @TEventCOntentHolder.OnResize); + RegisterObjectEvent(Crtl, 'OnTimer', @TEventCOntentHolder.OnTimer); + RegisterObjectEvent(Crtl, 'OnMousedown', @TEventCOntentHolder.OnMousedown); + RegisterObjectEvent(Crtl, 'OnMouseup', @TEventCOntentHolder.OnMouseup); + RegisterObjectEvent(Crtl, 'OnMouseMove', @TEventCOntentHolder.OnMouseMove); + RegisterObjectEvent(Crtl, 'OnKeypress', @TEventCOntentHolder.OnKeypress); + RegisterObjectEvent(Crtl, 'OnKeydown', @TEventCOntentHolder.OnKeydown); + RegisterObjectEvent(Crtl, 'OnKeyup', @TEventCOntentHolder.OnKeyup); + + For I := 0 To high(EXTF_EventLinks) Do + If (EXTF_EventLinks[i].Control = Crtl) and + (EXTF_EventLinks[i].EventType = EType) Then + Begin + If PCardinal(Params^[2].Data)^ = 0 Then + Begin + EXTF_EventLinks[i] := EXTF_EventLinks[high(EXTF_EventLinks)]; + SetLength(EXTF_EventLinks, length(EXTF_EventLinks) - 1); + exit; + End; + EXTF_EventLinks[i].Address := PCardinal(Params^[2].Data)^; + exit; + End; + + SetLength(EXTF_EventLinks, length(EXTF_EventLinks) + 1); + With EXTF_EventLinks[high(EXTF_EventLinks)] Do + Begin + Control := Crtl; + Address := PCardinal(Params^[2].Data)^; + EventType := EType; + DoCall := False; + End; +End; + +Procedure _CallEvents(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + EXTF_CallEvents; +End; + +Procedure _WaitForEvent(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + While not EXTF_CallEvents Do + Begin + Application.ProcessMessages; + sleep(10); + End; +End; + +Procedure _EventParamX(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PInteger(Result^.Data)^ := EventContentHolder.Ax; +End; + +Procedure _EventParamY(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PInteger(Result^.Data)^ := EventContentHolder.Ay; +End; + +Procedure _EventParamSender(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + TObject(PPointer(Result^.Data)^) := EventContentHolder.ASender; +End; + +Procedure _EventKey(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PWord(Result^.Data)^ := EventContentHolder.AKey; +End; + +Procedure _EventParamShiftState(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Type + PShiftState = ^TShiftState; +Begin + PShiftState(Result^.Data)^ := EventContentHolder.AShift; +End; + +Procedure _EventParamIsControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssCtrl in EventContentHolder.AShift; +End; + +Procedure _EventParamIsAlt(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssAlt in EventContentHolder.AShift; +End; + +Procedure _EventParamIsShift(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssShift in EventContentHolder.AShift; +End; + +Procedure _EventParamIsLeft(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssLeft in EventContentHolder.AShift; +End; + +Procedure _EventParamIsRight(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssRight in EventContentHolder.AShift; +End; + +Procedure _EventParamIsMiddle(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := ssMiddle in EventContentHolder.AShift; +End; + +//============================================================================== +//============================================================================== + +Procedure _SetPos(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TControl Then + Begin + Control.Left := PInteger(Params^[1].Data)^; + Control.Top := PInteger(Params^[2].Data)^; + End; +End; + +Procedure _SetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TForm Then + Begin + TForm(Control).ClientWidth := PInteger(Params^[1].Data)^; + TForm(Control).ClientHeight := PInteger(Params^[2].Data)^; + exit; + End; + If Control is TControl Then + Begin + Control.Width := PInteger(Params^[1].Data)^; + Control.Height := PInteger(Params^[2].Data)^; + End; +End; + +Procedure _SetVisibility(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := TControl(PPointer(Params^[0].Data)^); + Control.Visible := PBoolean(Params^[0].Data)^; +End; + +Procedure _GetVisibility(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := TControl(PPointer(Params^[0].Data)^); + PBoolean(Result^.Data)^ := Control.Visible; +End; + +Procedure _GetDC(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := GetDC(PCardinal(Params^[0].Data)^); +End; + +Procedure _GetHandle(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TWinControl Then + PCardinal(Result^.Data)^ := TWinControl(Control).Handle + Else + If Control is TControl Then + PCardinal(Result^.Data)^ := Control.Parent.Handle; +End; + +Procedure _AddLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TCustomListBox Then + TCustomListBox(Control).Items.Add(PAnsiString(Params^[1].Data)^); + If Control is TCustomMemo Then + TCustomMemo(Control).Lines.Add(PAnsiString(Params^[1].Data)^); +End; + +Procedure _InsertLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TCustomListBox Then + TCustomListBox(Control).Items.Insert(PInteger(Params^[1].Data)^, PAnsiString(Params^[2].Data)^); + If Control is TCustomMemo Then + TCustomMemo(Control).Lines.Insert(PInteger(Params^[1].Data)^, PAnsiString(Params^[2].Data)^); +End; + +Procedure _DeleteLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TCustomListBox Then + TCustomListBox(Control).Items.Delete(PInteger(Params^[1].Data)^); + If Control is TCustomMemo Then + TCustomMemo(Control).Lines.Delete(PInteger(Params^[1].Data)^); +End; + +Procedure _SetLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TCustomListBox Then + TCustomListBox(Control).Items[PInteger(Params^[1].Data)^] := PAnsiString(Params^[2].Data)^; + If Control is TCustomMemo Then + TCustomMemo(Control).Lines[PInteger(Params^[1].Data)^] := PAnsiString(Params^[2].Data)^; +End; + +Procedure _SetLineCount(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + Control : TControl; +Begin + Control := PControl(Params^[0].Data)^; + If Control is TCustomListBox Then + While TCustomListBox(Control).Items.Count > PInteger(Params^[1].Data)^ Do + TCustomListBox(Control).Items.Delete(TCustomListBox(Control).Items.Count - 1); + If Control is TCustomMemo Then + While TCustomMemo(Control).Lines.Count > PInteger(Params^[1].Data)^ Do + TCustomMemo(Control).Lines.Delete(TCustomMemo(Control).Lines.Count - 1); +End; + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Var + Decl : TRutisVarType; +Begin + OutputDebugString(PChar('Rutis_EXT_Formulars.RegisterEXTMethods - Registering RUTIS Formular Support')); + + Engine.RegExtMethod('CreateForm',{$IfDef FPC}@{$EndIf}_CreateForm, ['Boolean'], 'TControl', + 'Creates a RUTIS-Form' + sLineBreak + + '#1: Visibility of form after creation' + sLineBreak + + 'Returns: Created form'); + Engine.RegExtMethod('CrtlCreate',{$IfDef FPC}@{$EndIf}_CreateControl, ['TControl', 'String'], 'TControl', + 'Creates a new Control' + sLineBreak + + '#1 : Owner for the new Control' + sLineBreak + + '#2 : Class-Name of the new Control' + sLineBreak + + 'Returns: Created object'); + Engine.RegExtMethod('CrtlCreateComponent',{$IfDef FPC}@{$EndIf}_CreateComponent, ['TComponent', 'String'], 'TComponent', + 'Creates a new Component' + sLineBreak + + '#1 : Owner for the new Component' + sLineBreak + + '#2 : Class-Name of the new Component' + sLineBreak + + 'Returns: Created Component'); + Engine.RegExtMethod('CrtlDestroy',{$IfDef FPC}@{$EndIf}_DestroyControl, [], 'TControl', + 'Destroys a Control'); + + Engine.RegExtMethod('CrtlRegisterEvent',{$IfDef FPC}@{$EndIf}_RegisterEvent, ['TControl', 'String', 'Method'], '', + 'Registers an Event' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Event Name' + sLineBreak + + '#3 : Event Handler' + sLineBreak + + 'Possible Values for #2 are:' + sLineBreak + + '- OnClick, OnMouseDown, OnMouseUp, OnMouseMove,' + sLineBreak + + '- OnChange,' + sLineBreak + + '- OnKeyPress, OnKeyDown, OnKeyUp'); + Engine.RegExtMethod('CallEvents',{$IfDef FPC}@{$EndIf}_CallEvents, [], '', + 'Calls all activated events' + sLineBreak + + 'You need to link events to actions with RegisterEvent first'); + Engine.RegExtMethod('WaitForEvent',{$IfDef FPC}@{$EndIf}_WaitForEvent, [], '', + 'Waits for any Event to happen' + sLineBreak + + 'You need to link events to actions with RegisterEvent first'); + + Engine.RegExtMethod('EventParamX',{$IfDef FPC}@{$EndIf}_EventParamX, [], 'Integer', + 'Returns the "X" parameter of an occurred event'); + Engine.RegExtMethod('EventParamY',{$IfDef FPC}@{$EndIf}_EventParamY, [], 'Integer', + 'Returns the "Y" parameter of an occurred event'); + Engine.RegExtMethod('EventParamSender',{$IfDef FPC}@{$EndIf}_EventParamSender, [], 'TControl', + 'Returns the "Sender" parameter of an occurred event'); + Engine.RegExtMethod('EventParamKey',{$IfDef FPC}@{$EndIf}_EventKey, [], 'Word', + 'Returns the "Key" parameter of an occurred event'); + Engine.RegExtMethod('EventParamShiftState',{$IfDef FPC}@{$EndIf}_EventParamShiftState, [], 'Cardinal', + 'Returns the "ShiftState" parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsControl',{$IfDef FPC}@{$EndIf}_EventParamIsControl, [], 'Boolean', + 'Returns true, if "ssCrtl" is in he ShiftState parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsAlt',{$IfDef FPC}@{$EndIf}_EventParamIsAlt, [], 'Boolean', + 'Returns true, if "ssAlt" is in he ShiftState parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsShift',{$IfDef FPC}@{$EndIf}_EventParamIsShift, [], 'Boolean', + 'Returns true, if "ssShift" is in he ShiftState parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsLeft',{$IfDef FPC}@{$EndIf}_EventParamIsLeft, [], 'Boolean', + 'Returns true, if "ssLeft" is in he ShiftState parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsRight',{$IfDef FPC}@{$EndIf}_EventParamIsRight, [], 'Boolean', + 'Returns true, if "ssRight" is in he ShiftState parameter of an occurred event'); + Engine.RegExtMethod('EventParamIsMiddle',{$IfDef FPC}@{$EndIf}_EventParamIsMiddle, [], 'Boolean', + 'Returns true, if "ssMiddle" is in he ShiftState parameter of an occurred event'); + + Engine.RegExtMethod('CrtlSetVisibility',{$IfDef FPC}@{$EndIf}_SetVisibility, ['TControl', 'Boolean'], '', + 'Sets the Visibility of an Control' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Visibility'); + Engine.RegExtMethod('CrtlGetVisibility',{$IfDef FPC}@{$EndIf}_GetVisibility, ['TControl'], 'Boolean', + 'Sets the Visibility of an Control' + sLineBreak + + '#1 : Control' + sLineBreak + + 'Returns : Visibility of the Control'); + Engine.RegExtMethod('CrtlSetPos',{$IfDef FPC}@{$EndIf}_SetPos, ['TControl', 'Integer', 'Integer'], '', + 'Sets the Position of an Control' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Left' + sLineBreak + + '#3 : Top'); + Engine.RegExtMethod('CrtlSetSize',{$IfDef FPC}@{$EndIf}_SetSize, ['TControl', 'Integer', 'Integer'], '', + 'Sets the Position of an Control' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Width' + sLineBreak + + '#3 : Height'); + + Engine.RegExtMethod('GetDC',{$IfDef FPC}@{$EndIf}_GetDC, ['Cardinal'], 'Cardinal', + 'Returns the DeviceContext for a specific Handle' + sLineBreak + + '#1 : Handle' + sLineBreak + + 'Returns : DC'); + Engine.RegExtMethod('GetHandle',{$IfDef FPC}@{$EndIf}_GetHandle, ['TControl'], 'Cardinal', + 'Returns the Handle of a control (e.g. for GetDC)' + sLineBreak + + '#1 : Control' + sLineBreak + + 'Returns : Handle'); + + Engine.RegExtMethod('CrtlAddLine',{$IfDef FPC}@{$EndIf}_AddLine, ['TControl', 'String'], '', + 'Adds a new Line/Item in TMemo/TListBox/etc.' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Line to add'); + Engine.RegExtMethod('CrtlInsertLine',{$IfDef FPC}@{$EndIf}_InsertLine, ['TControl', 'Integer', 'String'], '', + 'Adds a new Line/Item in TMemo/TListBox/etc.' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Insert place' + sLineBreak + + '#3 : Line to add'); + + Engine.RegExtMethod('CrtlDeleteLine',{$IfDef FPC}@{$EndIf}_DeleteLine, ['TControl', 'Integer'], '', + 'Deletes a Line/Item in TMemo/TListBox/etc.' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Line to delete'); + Engine.RegExtMethod('CrtlSetLine',{$IfDef FPC}@{$EndIf}_SetLine, ['TControl', 'Integer', 'String'], '', + 'Sets the text of a Line/Item in TMemo/TListBox/etc.' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Line' + sLineBreak + + '#2 : New text'); + Engine.RegExtMethod('CrtlSetLineCount',{$IfDef FPC}@{$EndIf}_SetLineCount, ['TControl', 'Integer'], '', + 'Sets the number of Lines/Items in TMemo/TListBox/etc.' + sLineBreak + + '#1 : Control' + sLineBreak + + '#2 : Line-count'); //CrtlSetLineCount + + OutputDebugString(PChar('Rutis_EXT_Formulars.RegisterEXTMethods - Successfully registered RUTIS Formular Support')); +End; + +//============================================================================== +//============================================================================== + +Initialization + EventContentHolder := TEventContentHolder.Create; +Finalization + EventContentHolder.Free; +End. + diff --git a/Units/RUTIS/Rutis_EXT_OpenGl.pas b/Units/RUTIS/Rutis_EXT_OpenGl.pas new file mode 100644 index 0000000..174ba96 --- /dev/null +++ b/Units/RUTIS/Rutis_EXT_OpenGl.pas @@ -0,0 +1,1049 @@ +Unit Rutis_EXT_OpenGl; + +Interface + +Uses + Windows, Controls, SysUtils, + Rutis_Engine, Rutis_Defs, + dglOpenGl, + TFrustumClass, + OpenGl_Texture_Manager, + OpenGl_Types, + OpenGl_Functions, + OpenGl_Speed_Lists; + +Var + Rogl_Display : TWinControl; + Rogl_DC, Rogl_RC : HDC; + Rogl_CamPos, + Rogl_CamRot : TVector3f; + Rogl_NearClipping, + Rogl_FarClipping : Single; + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Procedure ROgl_SetViewport(WinControl : TWinControl); +Procedure DestroyRoglContext; +Procedure ResizeRoglContext; + +Implementation + +Var + ROGL_Width, ROGL_Height : Integer; + //============================================================================== + //============================================================================== + +Function CreateContext : Integer; +Begin + Result := 0; + If not InitOpenGl Then exit; + Result := CreateRenderingContext(Rogl_DC, [opDoubleBuffered], 32, 24, 0, 32, 0, 0); +End; + +Procedure DestroyRoglContext; +Begin + SetLength(TexManager_TexturePaths, 0); + AddTexturePath('.\'); + AddTexturePath(ExtractFileDir(ParamStr(0))); + FreeTextures; + DeleteSpeedLists; + Rogl_NearClipping := 1; + Rogl_FarClipping := 1000; + If Rogl_DC <> 0 Then + Begin + If Rogl_RC <> 0 Then + Begin + DeactivateRenderingContext; + DestroyRenderingContext(Rogl_RC); + Rogl_RC := 0; + End; + Try + ReleaseDC(Rogl_Display.Handle, Rogl_DC); + Except + End; + Rogl_DC := 0; + Rogl_CamPos := nullvect; + Rogl_CamRot := nullvect; + sleep(1); + End; +End; + +Procedure ResizeRoglContext; +Begin + If (Rogl_DC <> 0) and (Rogl_RC <> 0) Then + Begin + glViewport(0, 0, Rogl_Display.Width, Rogl_Display.Height); + {glMatrixMode(GL_PROJECTION); + glLoadIdentity; + gluPerspective(45.0, ClientWidth/ClientHeight, NearClipping, FarClipping); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity;} + End; +End; + +Procedure ROgl_SetViewport(WinControl : TWinControl); +Begin + If not (WinControl is TWinControl) Then exit; + Rogl_Display := WinControl; + + DestroyRoglContext; + + If not (Rogl_Display is TWinControl) Then + Rogl_Display := Rogl_Display.Parent; + + Rogl_DC := GetDC(Rogl_Display.Handle); + Rogl_RC := CreateContext; + ActivateRenderingContext(Rogl_DC, Rogl_RC); + + sleep(1); + + glClearColor(0, 0, 0, 0); + glEnable(GL_DEPTH_TEST); + glEnable(GL_CULL_FACE); +End; + +//============================================================================== +//============================================================================== +{$REGION 'OpenGl-Extension glx'} + +Procedure _glxSetViewportControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + ROgl_SetViewport(TWinControl(PPointer(Params^[0].Data)^)); +End; + +Procedure _InitOpenGL(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If Rogl_Display = nil Then exit; + + DestroyRoglContext; + + Rogl_DC := GetDC(Rogl_Display.Handle); + //If not InitOpenGl then exit; + Rogl_RC := CreateContext; + ActivateRenderingContext(Rogl_DC, Rogl_RC); + + sleep(1); + + glClearColor(0, 0, 0, 0); + glEnable(GL_DEPTH_TEST); + glEnable(GL_COLOR_MATERIAL); + glEnable(GL_CULL_FACE); +End; + +Procedure _glxNewFrame(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If Rogl_RC = 0 Then _InitOpenGL(nil, nil); + If Rogl_RC = 0 Then exit; + + SwapBuffers(Rogl_DC); + + If (Rogl_Display.Width <> ROGL_Width) or (Rogl_Display.Height <> ROGL_Height) Then + Begin + ROGL_Width := Rogl_Display.Width; + ROGL_Width := Rogl_Display.Height; + glViewport(0, 0, Rogl_Display.Width, Rogl_Display.Height); + End; + + glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); + + glMatrixMode(GL_PROJECTION); + glLoadIdentity; + gluPerspective(45.0, Rogl_Display.Width / Rogl_Display.Height, Rogl_NearClipping, Rogl_FarClipping); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity; + + glRotateV(Vector(-Rogl_CamRot.X, -Rogl_CamRot.Y, -Rogl_CamRot.Z)); + glTranslatef(-Rogl_CamPos.X, -Rogl_CamPos.Y, -Rogl_CamPos.Z); +End; + +Procedure _glxSwapBuffers(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SwapBuffers(Rogl_DC); +End; + +Procedure _glxSetNearFarClipping(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_NearClipping := PSingle(Params^[0].Data)^; + Rogl_FarClipping := PSingle(Params^[1].Data)^; +End; + +Procedure _glxGetTexture(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PInteger(Result^.Data)^ := ApplyTexture(PAnsiString(Params^[0].Data)^, False); +End; + +Procedure _glxApplyTexture(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + ApplyTexture(PAnsiString(Params^[0].Data)^); +End; + +Procedure _glxCamPos(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_CamPos.X := PSingle(Params^[0].Data)^; + Rogl_CamPos.Y := PSingle(Params^[1].Data)^; + Rogl_CamPos.Z := PSingle(Params^[2].Data)^; +End; + +Procedure _glxCamRot(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_CamRot.X := PSingle(Params^[0].Data)^; + Rogl_CamRot.Y := PSingle(Params^[1].Data)^; + Rogl_CamRot.Z := PSingle(Params^[2].Data)^; +End; + +Procedure _glxCalculateFrustum(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Frustum.Calculate; +End; + +Procedure _glxIsPointInFrustum(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsPointWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glxIsSphereInFrustum(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsSphereWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glxIsBoxInFrustum(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsBoxWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + PSingle(Params^[5].Data)^); +End; + +Procedure _glxIsPointInFrustumV(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsPointWithin( + PVector3f(Params^[0].Data)^.x, + PVector3f(Params^[0].Data)^.y, + PVector3f(Params^[0].Data)^.z); +End; + +Procedure _glxIsSphereInFrustumV(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsSphereWithin( + PPVector3f(Params^[0].Data)^^.x, + PPVector3f(Params^[0].Data)^^.y, + PPVector3f(Params^[0].Data)^^.z, + PSingle(Params^[1].Data)^); +End; + +Procedure _glxIsBoxInFrustumV(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsBoxWithin( + PVector3f(Params^[0].Data)^.x, + PVector3f(Params^[0].Data)^.y, + PVector3f(Params^[0].Data)^.z, + PVector3f(Params^[1].Data)^.x, + PVector3f(Params^[1].Data)^.y, + PVector3f(Params^[1].Data)^.z); +End; + +Procedure _glSphere(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + slSphere(PInteger(Params^[0].Data)^{,Params^[1]}); +End; +Procedure _glCube(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + slCube(1, 1, 1, PInteger(Params^[0].Data)^); +End; + +{$ENDREGION} + +//============================================================================== +//====================== OPENGL native functions =============================== +//============================================================================== + +{$REGION 'Other OpenGl Functions'} + +Procedure _glBegin(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBegin(PCardinal(Params^[0].Data)^); +End; + +Procedure _glEnd(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEnd; +End; + +Procedure _glClear(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glClear(PCardinal(Params^[0].Data)^); +End; + +Procedure _glFlush(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glFlush; +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'OpenGl-States'} + +Procedure _glEnable(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEnable(PInteger(Params^[0].Data)^); +End; + +Procedure _glDisable(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glDisable(PInteger(Params^[0].Data)^); +End; + +Procedure _glPushAttrib(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPushAttrib(PInteger(Params^[0].Data)^); +End; + +Procedure _glPopAttrib(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPopAttrib; +End; + +//============================================================================== + +Procedure _glCullFace(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glCullFace(PCardinal(Params^[0].Data)^); +End; + +Procedure _glViewport(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glViewport(PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, PInteger(Params^[2].Data)^, PInteger(Params^[3].Data)^); +End; + +Procedure _glLineWidth(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLineWidth(PSingle(Params^[0].Data)^); +End; + +Procedure _glBlendFunc(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBlendFunc(PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^); +End; + +Procedure _glClearColor(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glClearColor(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glAccum(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glAccum(PCardinal(Params^[0].Data)^, PSingle(Params^[1].Data)^); +End; + +Procedure _glReadBuffer(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glReadBuffer(PCardinal(Params^[0].Data)^); +End; + +Procedure _glPolygonMode(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPolygonMode(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^); +End; + +Procedure _glPolygonOffset(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPolygonOffset(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Matrix'} + +Procedure _glMatrixMode(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glMatrixMode(PCardinal(Params^[0].Data)^); +End; + +Procedure _glPushMatrix(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPushMatrix; +End; + +Procedure _glPopMatrix(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPopMatrix; +End; + +Procedure _glLoadIdentity(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLoadIdentity; +End; + +Procedure _glOrtho(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glOrtho(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, PSingle(Params^[5].Data)^); +End; + +Procedure _gluOrtho2D(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + gluOrtho2D(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +Procedure _gluPerspective(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + gluPerspective(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +//============================================================================== + +Procedure _glTranslatef(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTranslatef(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glTranslatefv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTranslatef(PPVector3f(Params^[0].Data)^^.X, + PPVector3f(Params^[0].Data)^^.Y, + PPVector3f(Params^[0].Data)^^.Z); +End; + +//============================================================================== + +Procedure _glRotatef(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +Procedure _glRotate3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PSingle(Params^[0].Data)^, 1, 0, 0); + glRotatef(PSingle(Params^[1].Data)^, 0, 1, 0); + glRotatef(PSingle(Params^[2].Data)^, 0, 0, 1); +End; + +Procedure _glRotate3fvect(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PVector3f(Params^[0].Data)^.X, 1, 0, 0); + glRotatef(PVector3f(Params^[0].Data)^.Y, 0, 1, 0); + glRotatef(PVector3f(Params^[0].Data)^.Z, 0, 0, 1); +End; + +Procedure _glRotate3fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PPVector3f(Params^[0].Data)^^.X, 1, 0, 0); + glRotatef(PPVector3f(Params^[0].Data)^^.Y, 0, 1, 0); + glRotatef(PPVector3f(Params^[0].Data)^^.Z, 0, 0, 1); +End; + +//============================================================================== + +Procedure _glScalef(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glScalef(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glScalefv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glScalef(PPVector3f(Params^[0].Data)^^.X, + PPVector3f(Params^[0].Data)^^.Y, + PPVector3f(Params^[0].Data)^^.Z); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Textures'} + +Procedure _glGenTexture(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glGenTextures(1, PGLUInt(Result^.Data)); +End; + +Procedure _glGenTextures(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glGenTextures(PInteger(Params^[0].Data)^, PGLUInt(PPointer(Params^[1].Data)^)); +End; + +Procedure _glBindTexture(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBindTexture(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^); +End; + +Procedure _glTexImage2D(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexImage2D(PCardinal(Params^[0].Data)^, PInteger(Params^[1].Data)^, PInteger(Params^[2].Data)^, + PInteger(Params^[3].Data)^, PInteger(Params^[4].Data)^, PInteger(Params^[5].Data)^, + PCardinal(Params^[6].Data)^, PCardinal(Params^[7].Data)^, PPointer(Params^[8].Data)^); +End; + +Procedure _glCopyTexImage2d(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glCopyTexImage2d(PCardinal(Params^[0].Data)^, PInteger(Params^[1].Data)^, PCardinal(Params^[2].Data)^, + PInteger(Params^[3].Data)^, PInteger(Params^[4].Data)^, PInteger(Params^[5].Data)^, PInteger(Params^[6].Data)^, + PInteger(Params^[7].Data)^); +End; + +Procedure _glTexParameteri(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexParameteri(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^, PInteger(Params^[2].Data)^); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Colors'} + +Procedure _glColor3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glColor3fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +Procedure _glColor4f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor4f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glColor4fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor4fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Light'} + +Procedure _glLighti(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLighti({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, PInteger(Params^[2].Data)^); +End; + +Procedure _glLightf(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLightf({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, PSingle(Params^[2].Data)^); +End; + +Procedure _glLight3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + 1); + glLightfv({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, @vec4f); +End; + +Procedure _glLight4f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + PSingle(Params^[5].Data)^); + glLightfv({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, @vec4f); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Fog'} + +Procedure _glFogi(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glFogi(PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^); +End; + +Procedure _glFogf(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glFogf(PInteger(Params^[0].Data)^, PSingle(Params^[1].Data)^); +End; + +Procedure _glFog3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + 1); + glFogfv(PInteger(Params^[0].Data)^, @vec4f); +End; + +Procedure _glFog4f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^); + glFogfv(PInteger(Params^[0].Data)^, @vec4f); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'DisplayLists'} + +Procedure _glGenLists(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := glGenLists(PCardinal(Params^[0].Data)^); +End; + +Procedure _glNewList(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNewList(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^); +End; + +Procedure _glEndList(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEndList; +End; + +Procedure _glCallList(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glCallList(PCardinal(Params^[0].Data)^); +End; + +Procedure _glListBase(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glListBase(PCardinal(Params^[0].Data)^); +End; + +{$ENDREGION} +//============================================================================== + +{$REGION 'Vectors'} + +Procedure _glVertex2f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex2f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^); +End; + +Procedure _glVertex3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glVertex4f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex4f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glNormal3f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNormal3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +//============================================================================== + +Procedure _glVertex2fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex2fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +Procedure _glVertex3fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +Procedure _glVertex4fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex4fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +Procedure _glNormal3fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNormal3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glTexCoord2f(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexCoord2f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^); +End; + +Procedure _glTexCoord2fv(Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexCoord2fv(PGLFloat(PCardinal(Params^[0].Data)^)); +End; + +{$ENDREGION} +//============================================================================== + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Begin + //============================================================================== + //====================== OPENGL ================================================ + //============================================================================== + + {$REGION 'gl-Extension glx'} + Engine.RegExtMethod('glxInitOpenGL',{$IfDef FPC}@{$EndIf}_InitOpenGL, [], ''); + Engine.RegExtMethod('glxSetViewportControl',{$IfDef FPC}@{$EndIf}_glxSetViewportControl, ['Pointer'], ''); + Engine.RegExtMethod('glxNewFrame',{$IfDef FPC}@{$EndIf}_glxNewFrame, [], ''); + Engine.RegExtMethod('glxSwapBuffers',{$IfDef FPC}@{$EndIf}_glxSwapBuffers, [], ''); + Engine.RegExtMethod('glxSetNearFarClipping',{$IfDef FPC}@{$EndIf}_glxSetNearFarClipping, ['Single', 'Single'], ''); + Engine.RegExtMethod('glxApplyTexture',{$IfDef FPC}@{$EndIf}_glxApplyTexture, ['String'], ''); + Engine.RegExtMethod('glxGetTexture',{$IfDef FPC}@{$EndIf}_glxGetTexture, ['String'], 'Integer'); + Engine.RegExtMethod('glxCamPos',{$IfDef FPC}@{$EndIf}_glxCamPos, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glxCamRot',{$IfDef FPC}@{$EndIf}_glxCamRot, ['Single', 'Single', 'Single'], ''); + + Engine.RegExtMethod('glxCalculateFrustum',{$IfDef FPC}@{$EndIf}_glxCalculateFrustum, [], ''); + Engine.RegExtMethod('glxIsPointInFrustum',{$IfDef FPC}@{$EndIf}_glxIsPointInFrustum, ['Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak); + Engine.RegExtMethod('glxIsSphereInFrustum',{$IfDef FPC}@{$EndIf}_glxIsSphereInFrustum, ['Single', 'Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak + + '#4: Radius' + sLineBreak); + Engine.RegExtMethod('glxIsBoxInFrustum',{$IfDef FPC}@{$EndIf}_glxIsBoxInFrustum, ['Single', 'Single', 'Single', 'Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak + + '#4: X' + sLineBreak + + '#5: Size-Y' + sLineBreak + + '#6: Size-Z' + sLineBreak); + Engine.RegExtMethod('glxIsPointInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsPointInFrustumV, ['PVector3f'], 'Boolean', + '#1: XYZ' + sLineBreak); + Engine.RegExtMethod('glxIsSphereInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsSphereInFrustumV, ['PVector3f', 'Single'], 'Boolean', + '#1: XYZ' + sLineBreak + + '#2: Radius' + sLineBreak); + Engine.RegExtMethod('glxIsBoxInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsBoxInFrustumV, ['PVector3f', 'PVector3f'], 'Boolean', + '#1: XYZ' + sLineBreak + + '#2: Size-XYZ'); + {$ENDREGION} + + + {$REGION 'OpenGl not-native functions'} + Engine.RegExtMethod('glxSwapBuffers',{$IfDef FPC}@{$EndIf}_glxSwapBuffers, [], ''); + Engine.RegExtMethod('glxApplyTexture',{$IfDef FPC}@{$EndIf}_glxApplyTexture, ['String'], ''); + Engine.RegExtMethod('glxGetTexture',{$IfDef FPC}@{$EndIf}_glxGetTexture, ['String'], 'Integer'); + Engine.RegExtMethod('glxCamPos',{$IfDef FPC}@{$EndIf}_glxCamPos, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glxCamRot',{$IfDef FPC}@{$EndIf}_glxCamRot, ['Single', 'Single', 'Single'], ''); + + Engine.RegExtMethod('glSphere',{$IfDef FPC}@{$EndIf}_glSphere, ['Integer'], ''); + Engine.RegExtMethod('glCube',{$IfDef FPC}@{$EndIf}_glCube, ['Integer'], ''); + {$ENDREGION} + + //============================================================================== + //====================== OPENGL native functions =============================== + //============================================================================== + + {$REGION 'Other OpenGl Functions'} + Engine.RegExtMethod('glBegin',{$IfDef FPC}@{$EndIf}_glBegin, ['Cardinal'], ''); + Engine.RegExtMethod('glEnd',{$IfDef FPC}@{$EndIf}_glEnd, [], ''); + Engine.RegExtMethod('glClear',{$IfDef FPC}@{$EndIf}_glClear, ['Cardinal'], ''); + Engine.RegExtMethod('glFlush',{$IfDef FPC}@{$EndIf}_glFlush, [], ''); + {$ENDREGION} + {$REGION 'OpenGl-States'} + Engine.RegExtMethod('glEnable',{$IfDef FPC}@{$EndIf}_glEnable, ['Integer'], ''); + Engine.RegExtMethod('glDisable',{$IfDef FPC}@{$EndIf}_glDisable, ['Integer'], ''); + Engine.RegExtMethod('glPushAttrib',{$IfDef FPC}@{$EndIf}_glPushAttrib, ['Integer'], ''); + Engine.RegExtMethod('glPopAttrib',{$IfDef FPC}@{$EndIf}_glPopAttrib, [], ''); + + Engine.RegExtMethod('glCullFace',{$IfDef FPC}@{$EndIf}_glCullFace, ['Cardinal'], ''); + Engine.RegExtMethod('glViewport',{$IfDef FPC}@{$EndIf}_glViewport, ['Integer', 'Integer', 'Integer', 'Integer'], '', + 'procedure(x, y, width, height: Integer)'); + Engine.RegExtMethod('glLineWidth',{$IfDef FPC}@{$EndIf}_glLineWidth, ['Single'], ''); + Engine.RegExtMethod('glBlendFunc',{$IfDef FPC}@{$EndIf}_glBlendFunc, ['Cardinal', 'Cardinal'], '', + 'procedure(sfactor, dfactor: Cardinal)'); + Engine.RegExtMethod('glClearColor',{$IfDef FPC}@{$EndIf}_glClearColor, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glAccum',{$IfDef FPC}@{$EndIf}_glAccum, ['Cardinal', 'Single'], '', + 'procedure(op: Cardinal; value: Single)'); + Engine.RegExtMethod('glReadBuffer',{$IfDef FPC}@{$EndIf}_glReadBuffer, ['Cardinal'], ''); + Engine.RegExtMethod('glPolygonMode',{$IfDef FPC}@{$EndIf}_glPolygonMode, ['Cardinal','Cardinal'], '', + 'procedure(face: Cardinal; mode: Cardinal)'); + Engine.RegExtMethod('glPolygonOffset',{$IfDef FPC}@{$EndIf}_glPolygonOffset, ['Single','Single'], '', + 'procedure(factor, units: Single)'); + {$ENDREGION} + {$REGION 'Matrix'} + Engine.RegExtMethod('glMatrixMode',{$IfDef FPC}@{$EndIf}_glMatrixMode, ['Cardinal'], ''); + Engine.RegExtMethod('glPushMatrix',{$IfDef FPC}@{$EndIf}_glPushMatrix, [], ''); + Engine.RegExtMethod('glPopMatrix',{$IfDef FPC}@{$EndIf}_glPopMatrix, [], ''); + Engine.RegExtMethod('glLoadIdentity',{$IfDef FPC}@{$EndIf}_glLoadIdentity, [], ''); + //Engine.RegExtMethod('glMultMatrixf',{$IfDef FPC}@{$EndIf}_glMultMatrixf, ['TMatrix4f'], ''); + + Engine.RegExtMethod('glOrtho',{$IfDef FPC}@{$EndIf}_glOrtho, ['Single', 'Single', 'Single', 'Single', 'Single', 'Single'], '', + 'procedure glOrtho(left, right, bottom, top, zNear, zFar: Single);'); + Engine.RegExtMethod('gluOrtho2D',{$IfDef FPC}@{$EndIf}_gluOrtho2D, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure gluOrtho2D(left, right, bottom, top: Single);'); + Engine.RegExtMethod('gluPerspective',{$IfDef FPC}@{$EndIf}_gluPerspective, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure gluPerspective(fovy, aspect, zNear, zFar: Single);'); + + Engine.RegExtMethod('glTranslatef',{$IfDef FPC}@{$EndIf}_glTranslatef, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glTranslatefv',{$IfDef FPC}@{$EndIf}_glTranslatefv, ['PVector3f'], ''); + Engine.RegExtMethod('glRotatef',{$IfDef FPC}@{$EndIf}_glRotatef, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure glRotatef(angle, x, y, z: Single);'); + Engine.RegExtMethod('glRotate3f',{$IfDef FPC}@{$EndIf}_glRotate3f, ['Single', 'Single', 'Single'], '', + 'procedure glRotate3f(x,y,z: Single);'); + Engine.RegExtMethod('glRotate3fv',{$IfDef FPC}@{$EndIf}_glRotate3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glRotate3fvect',{$IfDef FPC}@{$EndIf}_glRotate3fvect, ['TVector3f'], ''); + Engine.RegExtMethod('glScalef',{$IfDef FPC}@{$EndIf}_glScalef, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glScalefv',{$IfDef FPC}@{$EndIf}_glScalefv, ['PVector3f'], ''); + {$ENDREGION} + {$REGION 'Textures'} + Engine.RegExtMethod('glGenTexture',{$IfDef FPC}@{$EndIf}_glGenTexture, [], 'Cardinal'); + Engine.RegExtMethod('glGenTextures',{$IfDef FPC}@{$EndIf}_glGenTextures, ['Integer', 'PCardinal'], ''); + Engine.RegExtMethod('glBindTexture',{$IfDef FPC}@{$EndIf}_glBindTexture, ['Cardinal', 'Cardinal'], ''); + Engine.RegExtMethod('glTexImage2D',{$IfDef FPC}@{$EndIf}_glTexImage2D, ['Cardinal', 'Integer', + 'Integer', 'Integer', 'Integer', 'Integer', 'Cardinal', 'Cardinal', 'Pointer'], '', + 'procedure(target: Cardinal; level, internalformat, width, height, border: Integer; format, _type: Cardinal; pixels: Pointer)'); + Engine.RegExtMethod('glCopyTexImage2d',{$IfDef FPC}@{$EndIf}_glCopyTexImage2d, ['Cardinal', 'Integer', + 'Cardinal', 'Integer', 'Integer', 'Integer', 'Integer', 'Integer'], '', + 'procedure(target: Cardinal; level: Integer; internalformat: Cardinal; x, y, width, height, border: Integer)'); + Engine.RegExtMethod('glTexParameteri',{$IfDef FPC}@{$EndIf}_glTexParameteri, ['Cardinal', 'Cardinal', 'Integer'], '', + 'procedure(target, pname: Cardinal; param: Integer)'); + //Engine.RegExtMethod('glMaterialf',{$IfDef FPC}@{$EndIf}_glMaterialf, ['Single'], ''); + //Engine.RegExtMethod('glMaterial4f',{$IfDef FPC}@{$EndIf}_glMaterial4f, ['Single','Single','Single','Single'], ''); + {$ENDREGION} + {$REGION 'Colors'} + Engine.RegExtMethod('glColor3f',{$IfDef FPC}@{$EndIf}_glColor3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glColor4f',{$IfDef FPC}@{$EndIf}_glColor4f, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glColor3fv',{$IfDef FPC}@{$EndIf}_glColor3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glColor4fv',{$IfDef FPC}@{$EndIf}_glColor3fv, ['PVector4f'], ''); + {$ENDREGION} + {$REGION 'Light'} + Engine.RegExtMethod('glLighti',{$IfDef FPC}@{$EndIf}_glLighti, ['Integer', 'Integer', 'Integer'], ''); + Engine.RegExtMethod('glLightf',{$IfDef FPC}@{$EndIf}_glLightf, ['Integer', 'Integer', 'Single'], ''); + Engine.RegExtMethod('glLight3f',{$IfDef FPC}@{$EndIf}_glLight3f, ['Integer', 'Integer', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glLight4f',{$IfDef FPC}@{$EndIf}_glLight4f, ['Integer', 'Integer', 'Single', 'Single', 'Single', 'Single'], ''); + {$ENDREGION} + {$REGION 'Fog'} + Engine.RegExtMethod('glFogi',{$IfDef FPC}@{$EndIf}_glFogi, ['Integer', 'Integer'], ''); + Engine.RegExtMethod('glFogf',{$IfDef FPC}@{$EndIf}_glFogf, ['Integer', 'Single'], ''); + Engine.RegExtMethod('glFog3f',{$IfDef FPC}@{$EndIf}_glFog3f, ['Integer', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glFog4f',{$IfDef FPC}@{$EndIf}_glFog4f, ['Integer', 'Single', 'Single', 'Single', 'Single'], ''); + {$ENDREGION} + {$REGION 'DisplayLists'} + Engine.RegExtMethod('glGenLists',{$IfDef FPC}@{$EndIf}_glGenLists, ['Cardinal'], 'Cardinal'); + Engine.RegExtMethod('glNewList',{$IfDef FPC}@{$EndIf}_glNewList, ['Cardinal', 'Cardinal'], ''); + Engine.RegExtMethod('glEndList',{$IfDef FPC}@{$EndIf}_glEndList, [], ''); + Engine.RegExtMethod('glCallList',{$IfDef FPC}@{$EndIf}_glCallList, ['Cardinal'], ''); + Engine.RegExtMethod('glListBase',{$IfDef FPC}@{$EndIf}_glListBase, ['Cardinal'], ''); + {$ENDREGION} + {$REGION 'Vectors'} + Engine.RegExtMethod('glVertex2f',{$IfDef FPC}@{$EndIf}_glVertex2f, ['Single', 'Single'], ''); + Engine.RegExtMethod('glVertex3f',{$IfDef FPC}@{$EndIf}_glVertex3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glVertex4f',{$IfDef FPC}@{$EndIf}_glVertex4f, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glNormal3f',{$IfDef FPC}@{$EndIf}_glNormal3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glVertex2fv',{$IfDef FPC}@{$EndIf}_glVertex2fv, ['PVector2f'], ''); + Engine.RegExtMethod('glVertex3fv',{$IfDef FPC}@{$EndIf}_glVertex3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glVertex4fv',{$IfDef FPC}@{$EndIf}_glVertex4fv, ['PVector4f'], ''); + Engine.RegExtMethod('glNormal3fv',{$IfDef FPC}@{$EndIf}_glNormal3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glTexCoord2f',{$IfDef FPC}@{$EndIf}_glTexCoord2f, ['Single', 'Single'], ''); + Engine.RegExtMethod('glTexCoord2fv',{$IfDef FPC}@{$EndIf}_glTexCoord2fv, ['PVector2f'], ''); + {$ENDREGION} +End; + + + +End. + +{ +glGenLists +glDeleteLists +glCallList +glCallLists +glEndList +glListBase +glColorMaterial +glFrontFace +glPointSize +glDeleteTextures +glBindTexture +glDeleteTextures +glTexCoord2f +glTexCoord3f +glTexCoord4f +glTexGeni +glTexGenfv (4f) +glTexParameteri +glTexParameterf (4f) +glCopyTexImage2D +glCopyTexSubImage2D +glActiveTexture +glMultiTexCoord2f +glMultiTexCoord3f +glMultiTexCoord4f +glViewport + +gluLookAt + +glIsEnabled +glIsList +glIsTexture + + + + + +glBlendFuncSeparate +glBlendColor +glBlendEquation +glBlendEquationSeparate +glClearDepth +glClearStencil +glClipPlane +glColorMask +glDepthFunc +glDepthMask +glDepthRange +glFinish +glFlush +glFrustum + +glInitNames +glLoadName +glPushName +glPopName +glLightModelf (4f) +glLogicOp +glNewList +glRasterPos2f +glRasterPos3f +glWindowPos2f +glWindowPos3f +glRectf (x1,y1,x2,y2) +glRenderMode +glSelectBuffer +glShadeModel +glStencilFunc +glStencilFuncSeparate +glStencilMask +glStencilMaskSeparate +glStencilOp +glStencilOpSeparate +glTexImage2D +glTexSubImage2D +glTexImage3D +glTexSubImage3D +glFogCoordf +glGenQueries +glDeleteQueries +glIsQuery +glBeginQuery +glEndQuery +glGetQueryiv +glGetQueryObjectiv + +gluPickMatrix +gluLookAt +gluProject +gluUnProject +gluScaleImage +gluBuild2DMipmaps + + gluNewQuadric: TgluNewQuadric; + gluDeleteQuadric: TgluDeleteQuadric; + gluQuadricNormals: TgluQuadricNormals; + gluQuadricTexture: TgluQuadricTexture; + gluQuadricOrientation: TgluQuadricOrientation; + gluQuadricDrawStyle: TgluQuadricDrawStyle; + gluCylinder: TgluCylinder; + gluDisk: TgluDisk; + gluPartialDisk: TgluPartialDisk; + gluSphere: TgluSphere; + gluQuadricCallback: TgluQuadricCallback; + gluNewTess: TgluNewTess; + gluDeleteTess: TgluDeleteTess; + gluTessBeginPolygon: TgluTessBeginPolygon; + gluTessBeginContour: TgluTessBeginContour; + gluTessVertex: TgluTessVertex; + gluTessEndContour: TgluTessEndContour; + gluTessEndPolygon: TgluTessEndPolygon; + gluTessProperty: TgluTessProperty; + gluTessNormal: TgluTessNormal; + gluTessCallback: TgluTessCallback; + gluGetTessProperty: TgluGetTessProperty; + gluNewNurbsRenderer: TgluNewNurbsRenderer; + gluDeleteNurbsRenderer: TgluDeleteNurbsRenderer; + gluBeginSurface: TgluBeginSurface; + gluBeginCurve: TgluBeginCurve; + gluEndCurve: TgluEndCurve; + gluEndSurface: TgluEndSurface; + gluBeginTrim: TgluBeginTrim; + gluEndTrim: TgluEndTrim; + gluPwlCurve: TgluPwlCurve; + gluNurbsCurve: TgluNurbsCurve; + gluNurbsSurface: TgluNurbsSurface; + gluLoadSamplingMatrices: TgluLoadSamplingMatrices; + gluNurbsProperty: TgluNurbsProperty; + gluGetNurbsProperty: TgluGetNurbsProperty; + gluNurbsCallback: TgluNurbsCallback; + gluBeginPolygon: TgluBeginPolygon; + gluNextContour: TgluNextContour; + gluEndPolygon: TgluEndPolygon; + + glGetBooleanv: TglGetBooleanv; + glGetClipPlane: TglGetClipPlane; + glGetDoublev: TglGetDoublev; + glGetError: TglGetError; + glGetFloatv: TglGetFloatv; + glGetIntegerv: TglGetIntegerv; + glGetLightfv: TglGetLightfv; + glGetLightiv: TglGetLightiv; + glGetMapdv: TglGetMapdv; + glGetMapfv: TglGetMapfv; + glGetMapiv: TglGetMapiv; + glGetMaterialfv: TglGetMaterialfv; + glGetMaterialiv: TglGetMaterialiv; + glGetPixelMapfv: TglGetPixelMapfv; + glGetPixelMapuiv: TglGetPixelMapuiv; + glGetPixelMapusv: TglGetPixelMapusv; + glGetPointerv: TglGetPointerv; + glGetPolygonStipple: TglGetPolygonStipple; + glGetTexEnvfv: TglGetTexEnvfv; + glGetTexEnviv: TglGetTexEnviv; + glGetTexGendv: TglGetTexGendv; + glGetTexGenfv: TglGetTexGenfv; + glGetTexGeniv: TglGetTexGeniv; + glGetTexImage: TglGetTexImage; + glGetTexLevelParameterfv: TglGetTexLevelParameterfv; + glGetTexLevelParameteriv: TglGetTexLevelParameteriv; + glGetTexParameterfv: TglGetTexParameterfv; + glGetTexParameteriv: TglGetTexParameteriv; + +} diff --git a/Units/RUTIS/Rutis_Engine.pas b/Units/RUTIS/Rutis_Engine.pas new file mode 100644 index 0000000..2dc2f1b --- /dev/null +++ b/Units/RUTIS/Rutis_Engine.pas @@ -0,0 +1,2278 @@ +{/============================================================================== +//============================================================================== + +RUTIS-Engine (RunTimeScript-Engine) + +Rutis_Engine.pas (part of) RUTIS-Engine + +--> This unit contains the main part of the RUTIS-Engine + + +//============================================================================== + +Author : Björn Zeutzheim +E-Mail : bjoern@zeutzheim-boppard.de + +//============================================================================== + +License: Dieses Projekt (RUTIS-Engine) steht unter einer / + This project is licensed under the + Creative Commons 3.0 BY-NC-SA (German) License + +Diese Lizens beinhaltet / This license includes: +-> Namensnennung / Attribution +-> Keine kommerzielle Nutzung / Noncommercial +-> Weitergabe unter gleichen Bedingungen / Share Alike + +Ein ausformulierter Lizensvertrag ist über folgende Adresse erreichbar: +The Legal Code (the full license) can be read at the following adress: +> http: //creativecommons.org/licenses/by-nc-sa/3.0/de/ + +//============================================================================== +//==============================================================================} + +Unit Rutis_Engine; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +{.$define DEBUG} + +Uses + Windows, Forms, Classes, + {$ifdef DELPHI_7_UP}Variants,{$endif} + SysUtils, Math, + Rutis_Stack, Rutis_Defs, Rutis_Errors, RUTIS_Classes, RUTIS_Compiler_Delphi, + Rutis_EXT_Common, Rutis_ExtMethodInfoWin; + +Type + TRutisEngine = Class; + + TScriptLanguage = (slDelphi); + + //============================================================================== + TRegisterEXTMethods = Procedure(Engine : TRutisEngineBase); + TScriptAction = Procedure; + + TExtDllLink = Record + DllHandle : THandle; + RegisterEXTMethods : TRegisterEXTMethods; + StartScript : TScriptAction; + StopScript : TScriptAction; + PauseScript : TScriptAction; + Destroy : TScriptAction; + End; + + //============================================================================== + TWriProcedure = Procedure(s : String) Of Object; + + //============================================================================== + TRutisBreakpoint = Record + Line : Integer; + //CMD : Integer; + //Rule : Integer; + End; + + TRutisEngine = Class(TRutisEngineBase) + Private + Protected + fLastAdress : Pointer; + fLastAdressId : Integer; + //================================================ + fExtDlls : Array Of TExtDllLink; + //================================================ + Function GetExtAddrRange(P : Pointer; Exact : Boolean = False) : Integer; + //================================================ + {$REGION 'OpCodes'} + Procedure OpGen; + //============== + Procedure OpGen1; + Procedure OpGen2; + Procedure OpGen4; + //============== + Procedure OpAt; + Procedure OpAt2; + Procedure OpPtr; + Procedure OpPtrP; + Procedure OpCheckPtr; + //============== + Procedure OpLodR; + Procedure OpResStr; + //============== + Procedure OpLod; + Procedure OpSto; + Procedure OpMov; + //============== + Procedure OpLodP; + Procedure OpStoP; + //============== + Procedure OpGenStr; + Procedure OpCopyAStr; + Procedure OpCopyWStr; + Procedure OpStoAStr; + Procedure OpStoWStr; + //============== + Procedure OpScaleMem; + Procedure OpMemSize; + //============== + Procedure OpGetAStrLength; + Procedure OpSetAStrLength; + Procedure OpGetWStrLength; + Procedure OpSetWStrLength; + //============== + Procedure OpConv; + Procedure OpInc; + //============== + Procedure OpAdd; + Procedure OpSub; + Procedure OpMult; + Procedure OpDiv; + Procedure OpModulo; + Procedure OpEnumToSet; + //============== + Procedure OpAnd; + Procedure OpNot; + Procedure OpOr; + Procedure OpXOr; + //============== + Procedure OpWri; + Procedure OpExt; + Procedure OpCall; + Procedure OpRet; + //============== + Procedure OpJmp; + Procedure OpOpr; + Procedure OpJZ; + Procedure OpJL; + Procedure OpJG; + Procedure OpJGZ; + Procedure OpJLZ; + {$ENDREGION} + //================================================ + Public + ScriptLanguage : TScriptLanguage; + Breakpoints : Array Of TRutisBreakpoint; + //================================================ + OnWrite : TWriProcedure; + //================================================ + Constructor Create(StackBlockSize : Cardinal = 1024); + Destructor Destroy; Override; + //================================================ + Procedure ExecuteCMD(CMD : TRutisScriptCmd); + Procedure Run; + Procedure Stop; + Procedure Pause; + Procedure StepCmd; + Procedure StepLine; + Procedure ResetScriptState; + //================================================ + Procedure ToggleBreakpoint(Line : Integer); + Function GetBreakpoint(Line : Integer) : Integer; + Function GetBreakpointToCmd(CMD : Integer) : Integer; + //================================================ + Function DebugVarValue(AVarDecl : TRutisVarDecl) : String; + Function DebugVarName(AVarDecl : TRutisVarDecl) : String; + //================================================ + Function RegisterExtDll(FileName : String) : Boolean; + Procedure UnloadExtDlls; + //================================================ + Procedure GetByteCode(ByteCode : TStrings); + Function ExtMethodLinkToStr(ExtLink : TRutisExtMethodType; IncludeProc : Boolean) : String; + Function ShowExtMethodListWindow : TRutisExtMethodType; + //================================================ + //================================================ + End; + + //============================================================================== + //============================================================================== +Implementation + +Var + TempStrAdress : RutisString; + //============================================================================== + //============ TRutisEngine =================================================== + //============================================================================== + +Constructor TRutisEngine.Create(StackBlockSize : Cardinal); +Begin + Inherited Create(StackBlockSize); + + Compiler := TRutisCompilerDelphi.Create(self); + + OptProcessTimer := True; + OptProcessTimerCount := 100000; + + UnitFileManager.AddPath(ExtractFilePath(ParamStr(0))); + + Rutis_EXT_Common.RegisterEXTMethods(self); +End; + +Destructor TRutisEngine.Destroy; +Begin + UnitFileManager.Free; + UnloadExtDlls; + Inherited; +End; + +Function TRutisEngine.GetExtAddrRange(P : Pointer; Exact : Boolean = False) : Integer; +Begin + With ScriptData Do + If Exact Then + Begin + For Result := 0 To high(ScriptData.AddrRanges) Do + If P = ScriptData.AddrRanges[Result].Start Then + exit; + End + Else + For Result := 0 To high(ScriptData.AddrRanges) Do + Begin + If (Cardinal(P) >= Cardinal(ScriptData.AddrRanges[Result].Start)) and + (Cardinal(P) < Cardinal(ScriptData.AddrRanges[Result].Start) + ScriptData.AddrRanges[Result].Size) Then + Begin + exit; + End; + End; + If ScriptData.Stack.PointerInBlockData(P) Then + Begin + Result := -2; + exit; + End; + Result := -1; +End; + +//=================================== +//============ OpCodes ============== +//=================================== + +{$REGION 'OpCodes'} + +Procedure TRutisEngine.OpGen; +Begin + ScriptData.Stack.Push(ScriptData.CurrCmd.P1, True); +End; + +Procedure TRutisEngine.OpGen1; +Begin + ScriptData.Stack.PushByte(ScriptData.CurrCmd.P1); +End; + +Procedure TRutisEngine.OpGen2; +Begin + ScriptData.Stack.PushWord(ScriptData.CurrCmd.P1); +End; + +Procedure TRutisEngine.OpGen4; +Begin + ScriptData.Stack.PushCardinal(ScriptData.CurrCmd.P1); +End; + +//=================================== + +Procedure TRutisEngine.OpAt; +Begin + ScriptData.Stack.PopByte; + ScriptData.Stack.PushCardinal(Cardinal(fLastAdress)); +End; + +Procedure TRutisEngine.OpAt2; +Begin + ScriptData.Stack.PopByte; + ScriptData.Stack.PushCardinal(Cardinal(@fLastAdress)); +End; + +Procedure TRutisEngine.OpPtr; +Var + src : Cardinal; +Begin + src := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + + fLastAdressId := src; + fLastAdress := ScriptData.Stack.Data[src]; + + ScriptData.Stack.PushCardinal(Cardinal(fLastAdress)); +End; + +Procedure TRutisEngine.OpPtrP; +Var + src : Cardinal; +Begin + src := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(src + 3) Then exit; + + fLastAdressId := src; + fLastAdress := Pointer(ScriptData.Stack.ReadCardinal(src)); + If GetExtAddrRange(fLastAdress) = -1 Then + Begin + ScriptMessage('Address Error'); + exit; + End; + + ScriptData.Stack.PushCardinal(Cardinal(fLastAdress)); +End; + +Procedure TRutisEngine.OpCheckPtr; +Begin + fLastAdress := Pointer(ScriptData.Stack.ReadCardinal(ScriptData.Stack.Top - 4)); + If GetExtAddrRange(fLastAdress) = -1 Then + Begin + ScriptMessage('Address Error'); + exit; + End; +End; + +//=================================== + +Procedure TRutisEngine.OpLodR; +Var src : Integer; +Begin + If ScriptData.CurrCmd.P1 >= ScriptData.Ressources.Top Then exit; + src := ScriptData.Stack.Push(ScriptData.CurrCmd.P2); + fLastAdressId := ScriptData.CurrCmd.P1; + fLastAdress := ScriptData.Ressources.Data[ScriptData.CurrCmd.P1]; + + CopyStackData( + fLastAdress, + ScriptData.Stack.Data[src], + ScriptData.CurrCmd.P2); +End; + +Procedure TRutisEngine.OpResStr; +Begin + fLastAdressId := ScriptData.CurrCmd.P1; + TempStrAdress := ScriptData.Ressources.Data[ScriptData.CurrCmd.P1]; + ScriptData.Stack.PushString(TempStrAdress, False); +End; + +//=================================== + +Procedure TRutisEngine.OpLod; +Var + src, dst : Integer; +Begin + src := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(src + ScriptData.CurrCmd.P3 - 1) Then exit; + + dst := ScriptData.Stack.Push(ScriptData.CurrCmd.P3); + + fLastAdressId := src; + fLastAdress := ScriptData.Stack.Data[src]; + + CopyStackData( + fLastAdress, + ScriptData.Stack.Data[dst], + ScriptData.CurrCmd.P3); + //ScriptData.Stack.Move(src, dst, ScriptData.CurrCmd.P3); +End; + +Procedure TRutisEngine.OpSto; +Begin + OpMov; + ScriptData.Stack.Pop(ScriptData.CurrCmd.P3); +End; + +Procedure TRutisEngine.OpMov; +Var + dst, src : Integer; +Begin + dst := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(dst + ScriptData.CurrCmd.P3 - 1) Then exit; + + src := ScriptData.Stack.Top - ScriptData.CurrCmd.P3; + + fLastAdressId := dst; + fLastAdress := ScriptData.Stack.Data[dst]; + + CopyStackData( + ScriptData.Stack.Data[src], + fLastAdress, + ScriptData.CurrCmd.P3); + //ScriptData.Stack.Move(src, dst, ScriptData.CurrCmd.P3); +End; + +//=================================== + +Procedure TRutisEngine.OpLodP; +Var + src, dst : Integer; +Begin + src := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(src + 3) Then exit; + + fLastAdressId := src; + fLastAdress := Pointer(ScriptData.Stack.ReadCardinal(src)); + {If GetExtAddrRange(fLastAdress) = -1 Then + Begin + ScriptError('Address Error'); + exit; + End; } + + If ScriptData.CurrCmd.P2 = -1 Then + ScriptData.Stack.PopCardinal; + + dst := ScriptData.Stack.Push(ScriptData.CurrCmd.P3); + + CopyStackData( + fLastAdress, + ScriptData.Stack.Data[dst], + ScriptData.CurrCmd.P3); +End; + +Procedure TRutisEngine.OpStoP; +Var + src, dst : Integer; +Begin + If (ScriptData.CurrCmd.P2 = -1) and (ScriptData.CurrCmd.P1 = -4) Then + fLastAdress := PByte(ScriptData.Stack.PopCardinal) + Else + Begin + dst := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(dst + 3) Then exit; + fLastAdress := Pointer(ScriptData.Stack.ReadCardinal(dst)); + End; + + {If GetExtAddrRange(fLastAdress) = -1 Then + Begin + ScriptError('Address Error'); + exit; + End; } + + src := ScriptData.Stack.Top - ScriptData.CurrCmd.P3; + + CopyStackData( + ScriptData.Stack.Data[src], + fLastAdress, + ScriptData.CurrCmd.P3); + + ScriptData.Stack.Pop(ScriptData.CurrCmd.P3); +End; + +//=================================== + +Procedure TRutisEngine.OpGenStr; +Var + PStr : PAnsiString; +Begin + New(PStr); + PStr^ := ''; + ScriptData.Stack.PushString(PStr, True); +End; + +Procedure TRutisEngine.OpCopyAStr; +Var + StrSrc : RutisString; + StrDst : RutisString; +Begin + StrSrc := ScriptData.Stack.PopString; + StrDst := nil; + If StrSrc <> nil Then + Ansistring(StrDst) := PAnsiChar(StrSrc); + ScriptData.Stack.PushString(StrDst, True); +End; + +Procedure TRutisEngine.OpCopyWStr; +Var + StrSrc : RutisString; + StrDst : RutisString; +Begin + StrSrc := ScriptData.Stack.PopString; + StrDst := nil; + If StrSrc <> nil Then + WideString(StrDst) := PWideChar(StrSrc); + ScriptData.Stack.PushString(StrDst, True); +End; + +Procedure TRutisEngine.OpStoAStr; +Var + dst, src : Integer; + I : Integer; +Begin + dst := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(dst + 4 - 1) Then exit; + + src := ScriptData.Stack.Top - 4; + + fLastAdressId := dst; + fLastAdress := ScriptData.Stack.Data[dst]; + + If ScriptData.CurrCmd.P3 = 1 Then + fLastAdress := GetPPointer(fLastAdress); + + //Free old string data + PAnsiString(fLastAdress)^ := ''; + + CopyStackData( + ScriptData.Stack.Data[src], + fLastAdress, + 4); + + For I := 0 To high(ScriptData.Stack.FreeInfo) Do + If (ScriptData.Stack.FreeInfo[i].Adr = src) Then + Begin + ScriptData.Stack.FreeInfo[i].Adr := dst; + break; + End; + ScriptData.Stack.Pop(4); +End; + +Procedure TRutisEngine.OpStoWStr; +Var + dst, src : Integer; + I : Integer; +Begin + dst := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(dst + 4 - 1) Then exit; + + src := ScriptData.Stack.Top - 4; + + fLastAdressId := dst; + fLastAdress := ScriptData.Stack.Data[dst]; + + If ScriptData.CurrCmd.P3 = 1 Then + fLastAdress := GetPPointer(fLastAdress); + + //Free old string data + PWideString(fLastAdress)^ := ''; + + CopyStackData( + ScriptData.Stack.Data[src], + fLastAdress, + 4); + + For I := 0 To high(ScriptData.Stack.FreeInfo) Do + If (ScriptData.Stack.FreeInfo[i].Adr = src) Then + Begin + ScriptData.Stack.FreeInfo[i].Adr := dst; + break; + End; + ScriptData.Stack.Pop(4); +End; + +//=================================== + +Procedure TRutisEngine.OpScaleMem; +{ +Parameters +1) Cardinal -> Mem Pointer +2) Integer -> New Mem Block-count +3) Integer -> Mem Block-Size +Returns +1) Cardinal -> New Array Pointer +} +Var + i, + qSize, + ItemSize : Integer; + AChar : PChar; + old : TMemoryRange; +Begin + ItemSize := ScriptData.Stack.PopInteger; + If ItemSize < 0 Then + Begin + ScriptMessage('Mem Item-Size should be >= 0', etWarning); //etRuntimeError + ItemSize := 0; + End; + qSize := ScriptData.Stack.PopInteger; + If qSize < 0 Then + Begin + ScriptMessage('Mem length should be >= 0', etWarning); //etRuntimeError + qSize := 0; + End; + + i := GetExtAddrRange(Pointer(ScriptData.Stack.PopCardinal - 4), True); + If i = -1 Then + Begin + SetLength(ScriptData.AddrRanges, length(ScriptData.AddrRanges) + 1); + i := high(ScriptData.AddrRanges); + End; + + With ScriptData.AddrRanges[i] Do + Begin + old := ScriptData.AddrRanges[i]; + + //Neuen Speicher zuweisen und nullen + Size := qSize * ItemSize + 4; + ReallocMem(Start, Size); + + If old.size < Size Then + Begin + AChar := Pointer(Start); + Inc(Cardinal(AChar), old.Size); + FillChar(AChar^, Size - old.size, 0); + End; + PCardinal(Start)^ := qSize; + + ScriptData.Stack.PushCardinal(Cardinal(Start) + 4); + End; + If ScriptData.AddrRanges[i].Size = 0 Then + Begin + If length(ScriptData.AddrRanges) > 0 Then + ScriptData.AddrRanges[i] := ScriptData.AddrRanges[high(ScriptData.AddrRanges)]; + SetLength(ScriptData.AddrRanges, length(ScriptData.AddrRanges) - 1); + End; +End; + +Procedure TRutisEngine.OpMemSize; +{ +Parameters +1) Cardinal -> Array Pointer +Returns +1) Integer -> Array Length +} +Var + addr : PInteger; +Begin + addr := Pointer(ScriptData.Stack.PopCardinal); + If addr = nil Then + ScriptData.Stack.PushInteger(0) + Else + Begin + Dec(Cardinal(addr), 4); + ScriptData.Stack.PushInteger(addr^); + End; +End; + +//=================================== + +Procedure TRutisEngine.OpGetAStrLength; +{ +Parameters +1) String +Returns +1) Integer -> Array Length +} +Begin + ScriptData.Stack.PushInteger(length(Ansistring(ScriptData.Stack.PopString))); +End; + +Procedure TRutisEngine.OpSetAStrLength; +Var + Str : RutisString; + len : Integer; +Begin + len := ScriptData.Stack.PopInteger; + Str := ScriptData.Stack.PopString; + If len < 0 Then len := 0; + SetLength(Ansistring(Str), len); + ScriptData.Stack.PushString(Str, False); +End; + +Procedure TRutisEngine.OpGetWStrLength; +{ +Parameters +1) String +Returns +1) Integer -> Array Length +} +Begin + ScriptData.Stack.PushInteger(length(WideString(ScriptData.Stack.PopString))); +End; + +Procedure TRutisEngine.OpSetWStrLength; +Var + Str : RutisString; + len : Integer; +Begin + len := ScriptData.Stack.PopInteger; + Str := ScriptData.Stack.PopString; + If len < 0 Then len := 0; + SetLength(WideString(Str), len); + ScriptData.Stack.PushString(Str, False); +End; + +//=================================== + +Procedure TRutisEngine.OpConv; +Var Str : RutisString; +Begin + If ScriptData.CurrCmd.P1 = ScriptData.CurrCmd.P2 Then exit; + With ScriptData.Stack Do + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intEnum, + intAChar, + intBoolean : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + //intByte, + //intEnum, + //intAChar, + //intBoolean: PushByte(PopByte); + intShortInt : PushShortInt(PopByte); + intWChar, + intWord : PushWord(PopByte); + intSmallint : PushSmallint(PopByte); + intCardinal, + intArray, + intPointer : PushCardinal(PopByte); + intInteger : PushInteger(PopByte); + intSingle : PushSingle(PopByte); + intDouble : PushDouble(PopByte); + intExtended : PushExtended(PopByte); + intSet : PushCardinal(1 shl PopByte); + intAString : + Begin + Str := nil; + If TRutisIntType(ScriptData.CurrCmd.P1) = intAChar Then + Ansistring(Str) := PopAChar + Else + Ansistring(Str) := IntToStr(PopByte); + PushString(Str, True); + End; + End; + intShortInt : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(PopShortInt); + //intShortInt : PushShortInt(PopShortInt); + intWChar, + intWord : PushWord(PopShortInt); + intSmallint : PushSmallint(PopShortInt); + intCardinal, + intArray, + intPointer : PushCardinal(PopShortInt); + intInteger : PushInteger(PopShortInt); + intSingle : PushSingle(PopShortInt); + intDouble : PushDouble(PopShortInt); + intExtended : PushExtended(PopShortInt); + End; + intWChar, + intWord : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(PopWord); + intShortInt : PushShortInt(PopWord); + //intWord : PushWord(PopWord); + intSmallint : PushSmallint(PopWord); + intCardinal, + intArray, + intPointer : PushCardinal(PopWord); + intInteger : PushInteger(PopWord); + intSingle : PushSingle(PopWord); + intDouble : PushDouble(PopWord); + intExtended : PushExtended(PopWord); + intWString : + Begin + Str := nil; + If TRutisIntType(ScriptData.CurrCmd.P1) = intWChar Then + WideString(Str) := PopWChar + Else + WideString(Str) := IntToStr(PopWord); + PushString(Str, True); + End; + End; + intSmallint : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(PopSmallint); + intShortInt : PushShortInt(PopSmallint); + intWChar, + intWord : PushWord(PopSmallint); + //intSmallint : PushSmallint(PopSmallint); + intCardinal, + intArray, + intPointer : PushCardinal(PopSmallint); + intInteger : PushInteger(PopSmallint); + intSingle : PushSingle(PopSmallint); + intDouble : PushDouble(PopSmallint); + intExtended : PushExtended(PopSmallint); + End; + intCardinal, + intPointer : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(PopCardinal); + intShortInt : PushShortInt(PopCardinal); + intWChar, + intWord : PushWord(PopCardinal); + intSmallint : PushSmallint(PopCardinal); + //intCardinal, + //intArray, + //intPointer : PushCardinal(PopCardinal); + intInteger : PushInteger(PopCardinal); + intSingle : PushSingle(PopCardinal); + intDouble : PushDouble(PopCardinal); + intExtended : PushExtended(PopCardinal); + End; + intInteger : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(PopInteger); + intShortInt : PushShortInt(PopInteger); + intWChar, + intWord : PushWord(PopInteger); + intSmallint : PushSmallint(PopInteger); + intCardinal, + intArray, + intPointer : PushCardinal(PopInteger); + //intInteger : PushInteger(PopInteger); + intSingle : PushSingle(PopInteger); + intDouble : PushDouble(PopInteger); + intExtended : PushExtended(PopInteger); + End; + intSingle : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(round(PopSingle)); + intShortInt : PushShortInt(round(PopSingle)); + intWChar, + intWord : PushWord(round(PopSingle)); + intSmallint : PushSmallint(round(PopSingle)); + intCardinal, + intArray, + intPointer : PushCardinal(round(PopSingle)); + intInteger : PushInteger(round(PopSingle)); + //intSingle : PushSingle(PopSingle); + intDouble : PushDouble(PopSingle); + intExtended : PushExtended(PopSingle); + End; + intDouble : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(round(PopDouble)); + intShortInt : PushShortInt(round(PopDouble)); + intWChar, + intWord : PushWord(round(PopDouble)); + intSmallint : PushSmallint(round(PopDouble)); + intCardinal, + intArray, + intPointer : PushCardinal(round(PopDouble)); + intInteger : PushInteger(round(PopDouble)); + intSingle : PushSingle(PopDouble); + //intDouble : PushDouble(PopDouble); + intExtended : PushExtended(PopDouble); + End; + intExtended : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum, + intAChar, + intBoolean : PushByte(round(PopExtended)); + intShortInt : PushShortInt(round(PopExtended)); + intWChar, + intWord : PushWord(round(PopExtended)); + intSmallint : PushSmallint(round(PopExtended)); + intCardinal, + intArray, + intPointer : PushCardinal(round(PopExtended)); + intInteger : PushInteger(round(PopExtended)); + intSingle : PushSingle(PopExtended); + intDouble : PushDouble(PopExtended); + //intExtended : PushExtended(PopExtended); + End; + intShortString : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intAString : + Begin + Str := nil; + Ansistring(Str) := PopShortString; + PushString(Str, True); + End; + intWString : + Begin + Str := nil; + WideString(Str) := PopShortString; + PushString(Str, True); + End; + End; + intAString : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intShortString : + Begin + Str := PopString; + PushShortString(Ansistring(Str)); + End; + intWString : + Begin + Str := nil; + WideString(Str) := Ansistring(PopString); + PushString(Str, True); + End; + End; + intWString : Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intShortString : + Begin + PushShortString(WideString(PopString)); + End; + intAString : + Begin + Str := nil; + Ansistring(Str) := WideString(PopString); + PushString(Str, True); + End; + End; + Else + End; +End; + +Procedure TRutisEngine.OpInc; +Var + src : Cardinal; + incVal : Integer; +Begin + src := GetStackLvlAddress(ScriptData.CurrCmd.P1, ScriptData.CurrCmd.P2); + If CheckStackIndex(src + IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P3)] - 1) Then exit; + + fLastAdress := ScriptData.Stack.Data[src]; + + With ScriptData.Stack Do + Begin + incVal := PopInteger; + + Case TRutisIntType(ScriptData.CurrCmd.P3) Of + intByte, + intAChar : SetPByte(fLastAdress, GetPByte(fLastAdress) + incVal); + intShortInt : SetPShortInt(fLastAdress, GetPShortInt(fLastAdress) + incVal); + intWord : SetPWord(fLastAdress, GetPWord(fLastAdress) + incVal); + intSmallint : SetPSmallint(fLastAdress, GetPSmallint(fLastAdress) + incVal); + intCardinal, + intPointer, + intArray : SetPCardinal(fLastAdress, GetPCardinal(fLastAdress) + incVal); + intInteger : SetPInteger(fLastAdress, GetPInteger(fLastAdress) + incVal); + intSingle : SetPSingle(fLastAdress, GetPSingle(fLastAdress) + incVal); + intDouble : SetPDouble(fLastAdress, GetPDouble(fLastAdress) + incVal); + intExtended : SetPExtended(fLastAdress, GetPExtended(fLastAdress) + incVal); + Else + End; + End; +End; + +//=================================== + +Procedure TRutisEngine.OpAdd; +Var + dst1 : Pointer; + Size : Byte; + temp : Pointer; +Begin + Size := IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P1)]; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - 2 * Size]; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intEnum, + intAChar : SetPByte(dst1, GetPByte(dst1) + PopByte); + intShortInt : SetPShortInt(dst1, GetPShortInt(dst1) + PopShortInt); + intWord : SetPWord(dst1, GetPWord(dst1) + PopWord); + intSmallint : SetPSmallint(dst1, GetPSmallint(dst1) + PopSmallint); + intCardinal, + intPointer, + intArray : SetPCardinal(dst1, GetPCardinal(dst1) + PopCardinal); + intInteger : SetPInteger(dst1, GetPInteger(dst1) + PopInteger); + intSingle : SetPSingle(dst1, GetPSingle(dst1) + PopSingle); + intDouble : SetPDouble(dst1, GetPDouble(dst1) + PopDouble); + intExtended : SetPExtended(dst1, GetPExtended(dst1) + PopExtended); + intAString : + Begin + temp := GetPPointer(dst1); + AnsiString(temp) := AnsiString(temp) + PAnsiChar(PopString); + SetPPointer(dst1, temp); + //SetPPointer(dst1, Pointer(AnsiString(GetPPointer(dst1)) + PAnsiChar(PopString))); + //PAnsiString(dst1)^ := PAnsiString(dst1)^ + PAnsiChar(PopString); + End; + intWString : + Begin + temp := GetPPointer(dst1); + WideString(temp) := WideString(temp) + PWideChar(PopString); + SetPPointer(dst1, temp); + //SetPPointer(dst1, Pointer(WideString(GetPPointer(dst1)) + PWideChar(PopString))); + End; + intSet : + Begin + ScriptData.CurrCmd.P1 := ScriptData.CurrCmd.P2; + OpOr; + End; + Else + End; + End; +End; + +Procedure TRutisEngine.Opsub; +Var + dst1 : Pointer; + Size : Byte; +Begin + Size := IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P1)]; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intAChar : SetPByte(dst1, GetPByte(dst1) - PopByte); + intShortInt : SetPShortInt(dst1, GetPShortInt(dst1) - PopShortInt); + intWord : SetPWord(dst1, GetPWord(dst1) - PopWord); + intSmallint : SetPSmallint(dst1, GetPSmallint(dst1) - PopSmallint); + intCardinal, + intPointer, + intArray : SetPCardinal(dst1, GetPCardinal(dst1) - PopCardinal); + intInteger : SetPInteger(dst1, GetPInteger(dst1) - PopInteger); + intSingle : SetPSingle(dst1, GetPSingle(dst1) - PopSingle); + intDouble : SetPDouble(dst1, GetPDouble(dst1) - PopDouble); + intExtended : SetPExtended(dst1, GetPExtended(dst1) - PopExtended); + intSet : + Begin + ScriptData.CurrCmd.P1 := ScriptData.CurrCmd.P2; + OpNot; + OpAnd; + End; + Else + End; + End; +End; + +Procedure TRutisEngine.Opmult; +Var + dst1 : Pointer; + Size : Byte; +Begin + Size := IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P1)]; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intAChar : SetPByte(dst1, GetPByte(dst1) * PopByte); + intShortInt : SetPShortInt(dst1, GetPShortInt(dst1) * PopShortInt); + intWord : SetPWord(dst1, GetPWord(dst1) * PopWord); + intSmallint : SetPSmallint(dst1, GetPSmallint(dst1) * PopSmallint); + intCardinal, + intPointer, + intArray : SetPCardinal(dst1, GetPCardinal(dst1) * PopCardinal); + intInteger : SetPInteger(dst1, GetPInteger(dst1) * PopInteger); + intSingle : SetPSingle(dst1, GetPSingle(dst1) * PopSingle); + intDouble : SetPDouble(dst1, GetPDouble(dst1) * PopDouble); + intExtended : SetPExtended(dst1, GetPExtended(dst1) * PopExtended); + Else + End; + End; +End; + +Procedure TRutisEngine.Opdiv; +Var + dst1 : Pointer; + Size : Byte; +Begin + Size := IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P1)]; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intAChar : SetPByte(dst1, GetPByte(dst1) div PopByte); + intShortInt : SetPShortInt(dst1, GetPShortInt(dst1) div PopShortInt); + intWord : SetPWord(dst1, GetPWord(dst1) div PopWord); + intSmallint : SetPSmallint(dst1, GetPSmallint(dst1) div PopSmallint); + intCardinal, + intPointer, + intArray : SetPCardinal(dst1, GetPCardinal(dst1) div PopCardinal); + intInteger : SetPInteger(dst1, GetPInteger(dst1) div PopInteger); + intSingle : SetPSingle(dst1, GetPSingle(dst1) / PopSingle); + intDouble : SetPDouble(dst1, GetPDouble(dst1) / PopDouble); + intExtended : SetPExtended(dst1, GetPExtended(dst1) / PopExtended); + Else + End; + End; +End; + +Procedure TRutisEngine.OpEnumToSet; +Var + bit : Cardinal; + adr : PByte; +Begin + If ScriptData.CurrCmd.P1 <= 0 Then + Begin + ScriptMessage('Error - OpEnumToSet'); + exit; + End; + bit := ScriptData.Stack.PopByte; + adr := ScriptData.Stack.Data[ScriptData.Stack.Push(ScriptData.CurrCmd.P1, True)]; + {$ifndef FPC} + Asm + MOV EAX, adr + MOV EDX, bit + BTS [EAX],EDX // setzt CF=1 wenn das Bit count = 1 ist und setzt dann das Bit=1 + End; + {$else FPC} + inc(Cardinal(adr), bit div 8); + bit := bit mod 8; + bit := 1 shl bit; + adr^ := adr^ or bit; + {$endif FPC} +End; + +Procedure TRutisEngine.OpModulo; +Var + dst1 : Pointer; + Size : Byte; +Begin + Size := IntTypeSizes[TRutisIntType(ScriptData.CurrCmd.P1)]; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte, + intAChar : SetPByte(dst1, GetPByte(dst1) mod PopByte); + intShortInt : SetPShortInt(dst1, GetPShortInt(dst1) mod PopShortInt); + intWord : SetPWord(dst1, GetPWord(dst1) mod PopWord); + intSmallint : SetPSmallint(dst1, GetPSmallint(dst1) mod PopSmallint); + intCardinal, + intPointer, + intArray : SetPCardinal(dst1, GetPCardinal(dst1) mod PopCardinal); + intInteger : SetPInteger(dst1, GetPInteger(dst1) mod PopInteger); + //intSingle : SetPSingle(dst1, GetPSingle(dst1) mod PopSingle); + //intDouble : SetPDouble(dst1, GetPDouble(dst1) mod PopDouble); + //intExtended : SetPExtended(dst1, GetPExtended(dst1) mod PopExtended); + Else + End; + End; +End; + +//=================================== + +Procedure TRutisEngine.OpAnd; +Var + dst1, + dst2 : Pointer; + Size, + PartSize : Word; +Begin + Size := ScriptData.CurrCmd.P1; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case Size Of + 1 : SetPByte(dst1, GetPByte(dst1) and PopByte); + 2 : SetPWord(dst1, GetPWord(dst1) and PopWord); + 4 : SetPCardinal(dst1, GetPCardinal(dst1) and PopCardinal); + 8 : SetPInt64(dst1, GetPInt64(dst1) and PopInteger); + Else + dst1 := Data[Top - Size - Size]; + dst2 := Data[Top - Size]; + PartSize := 0; + While Size > 0 Do + Begin + Case Size Of + 1 : + Begin + SetPByte(dst1, GetPByte(dst1) and GetPByte(dst2)); + exit; + End; + 2..3 : + Begin + SetPWord(dst1, GetPWord(dst1) and GetPWord(dst2)); + PartSize := 2; + End; + 4..7 : + Begin + SetPCardinal(dst1, GetPCardinal(dst1) and GetPCardinal(dst2)); + PartSize := 4; + End; + Else + SetPInt64(dst1, GetPInt64(dst1) and GetPInt64(dst1)); + PartSize := 8; + End; + Inc(Cardinal(dst1), PartSize); + Inc(Cardinal(dst2), PartSize); + End; + End; + End; +End; + +Procedure TRutisEngine.OpOr; +Var + dst1, + dst2 : Pointer; + Size, + PartSize : Word; +Begin + Size := ScriptData.CurrCmd.P1; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case Size Of + 1 : SetPByte(dst1, GetPByte(dst1) or PopByte); + 2 : SetPWord(dst1, GetPWord(dst1) or PopWord); + 4 : SetPCardinal(dst1, GetPCardinal(dst1) or PopCardinal); + 8 : SetPInt64(dst1, GetPInt64(dst1) or PopInteger); + Else + dst1 := Data[Top - Size - Size]; + dst2 := Data[Top - Size]; + PartSize := 0; + While Size > 0 Do + Begin + Case Size Of + 1 : + Begin + SetPByte(dst1, GetPByte(dst1) or GetPByte(dst2)); + exit; + End; + 2..3 : + Begin + SetPWord(dst1, GetPWord(dst1) or GetPWord(dst2)); + PartSize := 2; + End; + 4..7 : + Begin + SetPCardinal(dst1, GetPCardinal(dst1) or GetPCardinal(dst2)); + PartSize := 4; + End; + Else + SetPInt64(dst1, GetPInt64(dst1) or GetPInt64(dst2)); + PartSize := 8; + End; + Inc(Cardinal(dst1), PartSize); + Inc(Cardinal(dst2), PartSize); + End; + End; + End; +End; + +Procedure TRutisEngine.OpXOr; +Var + dst1, + dst2 : Pointer; + Size, + PartSize : Word; +Begin + Size := ScriptData.CurrCmd.P1; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size - Size]; + Case Size Of + 1 : SetPByte(dst1, GetPByte(dst1)xor PopByte); + 2 : SetPWord(dst1, GetPWord(dst1)xor PopWord); + 4 : SetPCardinal(dst1, GetPCardinal(dst1)xor PopCardinal); + 8 : SetPInt64(dst1, GetPInt64(dst1)xor PopInteger); + Else + dst1 := Data[Top - Size - Size]; + dst2 := Data[Top - Size]; + PartSize := 0; + While Size > 0 Do + Begin + Case Size Of + 1 : + Begin + SetPByte(dst1, GetPByte(dst1)xor GetPByte(dst2)); + exit; + End; + 2..3 : + Begin + SetPWord(dst1, GetPWord(dst1)xor GetPWord(dst2)); + PartSize := 2; + End; + 4..7 : + Begin + SetPCardinal(dst1, GetPCardinal(dst1)xor GetPCardinal(dst2)); + PartSize := 4; + End; + Else + SetPInt64(dst1, GetPInt64(dst1)xor GetPInt64(dst2)); + PartSize := 8; + End; + Inc(Cardinal(dst1), PartSize); + Inc(Cardinal(dst2), PartSize); + End; + End; + End; +End; + +Procedure TRutisEngine.OpNot; +Var + dst1 : Pointer; + Size : Word; +Type + PByteBool = ^Bytebool; +Begin + Size := ScriptData.CurrCmd.P1; + With ScriptData.Stack Do + Begin + dst1 := Data[Top - Size]; + Case Size Of + 1 : + Begin + If ScriptData.CurrCmd.P2 = 1 Then + PByteBool(dst1)^ := not PByteBool(dst1)^ + Else + SetPByte(dst1, not GetPByte(dst1)); + End; + 2 : SetPWord(dst1, not GetPWord(dst1)); + 4 : SetPCardinal(dst1, not GetPCardinal(dst1)); + 8 : SetPInt64(dst1, not GetPInt64(dst1)); + Else + dst1 := Data[Top - Size]; + While Size > 0 Do + Begin + Case Size Of + 1 : + Begin + SetPByte(dst1, not GetPByte(dst1)); + exit; + End; + 2..3 : + Begin + SetPWord(dst1, not GetPWord(dst1)); + Inc(Cardinal(dst1), 2); + End; + 4..7 : + Begin + SetPCardinal(dst1, not GetPCardinal(dst1)); + Inc(Cardinal(dst1), 4); + End; + Else + SetPInt64(dst1, not GetPInt64(dst1)); + Inc(Cardinal(dst1), 8); + End; + End; + End; + End; +End; + +//=================================== + +Procedure TRutisEngine.OpExt; +Var + i, j : Integer; + VParams : TVariantArray; + RParams : TRutisParamInfoArray; + PParams : Array Of Pointer; + VRes : Variant; + RRes : TRutisParamInfo; + PRes : Cardinal; + ExtMethod : TRutisExtMethodType; + DllMethod : TRutisDllMethodType; + hDll : THandle; +Begin + If (ScriptData.CurrCmd.P1 < 0) or (ScriptData.CurrCmd.P1 > high(ScriptData.MethodTable)) Then + Begin + ScriptMessage('Could not find Method-Info entry in Method-Table'); + exit; + End; + ExtMethod := TRutisExtMethodType(ScriptData.MethodTable[ScriptData.CurrCmd.P1]); + DllMethod := TRutisDllMethodType(ExtMethod); + + //If (ExtMethod is TRutisExtMethodType) then + If (ExtMethod.ClassType = TRutisExtMethodType) Then + Begin + If Assigned(ExtMethod.VariMethod) Then + Begin + SetLength(VParams, length(ExtMethod.Params)); + j := ScriptData.Stack.Top - ExtMethod.ParamsSize; + For i := 0 To high(VParams) Do + Begin + VParams[i] := ScriptData.Stack.ReadToVariant( + ExtMethod.Params[i].InternalType, j); + j := j + ExtMethod.Params[i].Size; + End; + + ScriptData.Stack.Pop(ExtMethod.ParamsSize); + + ExtMethod.VariMethod(@VParams, @VRes); + + If ExtMethod.IsFunction Then + Begin + j := ScriptData.Stack.Top - ExtMethod.MethodResult.Size; + ScriptData.Stack.WriteFromVariant(ExtMethod.MethodResult.InternalType, j, VRes); + If ExtMethod.MethodResult.InternalType = intAString Then + ScriptData.Stack.AddFreeData(j, True); + End; + + If ExtMethod.IsFunction and (ScriptData.CurrCmd.P2 = 1) Then + ScriptData.Stack.Pop(ExtMethod.MethodResult.Size); + End + Else + Begin + SetLength(RParams, length(ExtMethod.Params)); + j := ScriptData.Stack.Top - ExtMethod.ParamsSize; + For i := 0 To high(RParams) Do + Begin + RParams[i].Adr := j; + RParams[i].Data := ScriptData.Stack.GetByte(j); + RParams[i].Size := ExtMethod.Params[i].Size; + RParams[i].IntType := ExtMethod.Params[i].InternalType; + j := j + ExtMethod.Params[i].Size; + End; + + If ExtMethod.IsFunction Then + Begin + j := ScriptData.Stack.Top - ExtMethod.ParamsSize - ExtMethod.MethodResult.Size; + RRes.Adr := j; + RRes.Data := ScriptData.Stack.GetByte(j); + RRes.Size := ExtMethod.MethodResult.Size; + RRes.IntType := ExtMethod.MethodResult.InternalType; + If RRes.IntType = intAString Then + ScriptData.Stack.AddFreeData(j, True); + End; + + ExtMethod.StackMethod(@RParams, @RRes); + + ScriptData.Stack.Pop(ExtMethod.ParamsSize); + + If ExtMethod.IsFunction and (ScriptData.CurrCmd.P2 = 1) Then + ScriptData.Stack.Pop(ExtMethod.MethodResult.Size); + End; + exit; + End; + {$ifndef FPC} + If (DllMethod is TRutisDllMethodType) Then + Begin + SetLength(PParams, length(DllMethod.Params)); + j := ScriptData.Stack.Top - DllMethod.ParamsSize; + For i := 0 To high(PParams) Do + Begin + PParams[i] := PPointer(ScriptData.Stack.GetCardinal(j))^; + j := j + DllMethod.Params[i].Size; + End; + + If DllMethod.ProcAddress = nil Then + Begin + //Get Libary + hDll := GetModuleHandle(PChar(DllMethod.DllName)); + If hDll = 0 Then + hDll := LoadLibrary(PChar(DllMethod.DllName)); + //Get Proc-Address + If hDll <> 0 Then + DllMethod.ProcAddress := GetProcAddress(hDll, PChar(DllMethod.ProcName)); + End; + //PParams[0] := @j; + DynamicDllCall(DllMethod.ProcAddress, DllMethod.IsFunction, PRes, PParams); + //OnWrite(IntToStr(j)); + + ScriptData.Stack.Pop(DllMethod.ParamsSize); + + If DllMethod.IsFunction and (ScriptData.CurrCmd.P2 <> 1) Then + Begin + j := ScriptData.Stack.Top - DllMethod.ParamsSize - DllMethod.MethodResult.Size; + CopyStackData(@PRes, ScriptData.Stack.GetByte(j), DllMethod.MethodResult.Size); + {If DllMethod.ResultType.InternalType = intAString then + begin + New(PStr); + PPAnsiString(RRes.Data)^ := PStr; + ScriptData.Stack.AddFreeData(j, true); + end;} + End; + + If DllMethod.IsFunction and (ScriptData.CurrCmd.P2 = 1) Then + ScriptData.Stack.Pop(DllMethod.MethodResult.Size); + End; + {$endif} +End; + +Procedure TRutisEngine.OpWri; +Var str : String; +Begin + If not Assigned(OnWrite) Then exit; + Case TRutisIntType(ScriptData.CurrCmd.P1) Of + intByte : str := IntToStr(ScriptData.Stack.PopByte); + intWord : str := IntToStr(ScriptData.Stack.PopWord); + intCardinal, + IntPointer, + intArray : str := IntToStr(ScriptData.Stack.PopCardinal); + intShortInt : str := IntToStr(ScriptData.Stack.PopShortInt); + intSmallint : str := IntToStr(ScriptData.Stack.PopSmallint); + intInteger : str := IntToStr(ScriptData.Stack.PopInteger); + intSingle : str := FloatToStr(ScriptData.Stack.PopSingle); + intDouble : str := FloatToStr(ScriptData.Stack.PopDouble); + intExtended : str := FloatToStr(ScriptData.Stack.PopExtended); + intAChar : str := ScriptData.Stack.PopAChar; + intAString : str := Ansistring(ScriptData.Stack.PopString); + intWChar : str := ScriptData.Stack.PopWChar; + intWString : str := WideString(ScriptData.Stack.PopString); + End; + OnWrite(str); +End; + +//=================================== + +Procedure TRutisEngine.OpCall; +Var NewLine : Cardinal; +Begin + If ScriptData.CurrCmd.P1 < 0 Then + NewLine := ScriptData.Stack.PopCardinal - 1 + Else + NewLine := ScriptData.CurrCmd.P1 - 1; + // first Save last States + SetLength(ScriptData.CallStack, length(ScriptData.CallStack) + 1); + ScriptData.CallStack[high(ScriptData.CallStack)].CallLine := ScriptData.CodeLine; //Save CallLine + ScriptData.CallStack[high(ScriptData.CallStack)].StackBase := ScriptData.Stack.Top; //Set new StackBase + ScriptData.CallStack[high(ScriptData.CallStack)].Level := ScriptData.CurrCmd.P2; //Set Method-Level + // change line + ScriptData.CodeLine := NewLine; +End; + +Procedure TRutisEngine.OpRet; +Begin + If length(ScriptData.CallStack) = 0 Then + Begin + ScriptData.CodeLine := -1; + exit; + End; + // Reset old States + ScriptData.CodeLine := ScriptData.CallStack[high(ScriptData.CallStack)].CallLine; + ScriptData.Stack.PopTo(ScriptData.CallStack[high(ScriptData.CallStack)].StackBase); + //ScriptData.Stack.Top := ScriptData.CallStack[high(ScriptData.CallStack)].StackBase; + SetLength(ScriptData.CallStack, length(ScriptData.CallStack) - 1); + //PopStack for Parameters + ScriptData.Stack.Pop(ScriptData.CurrCmd.P1); +End; + +Procedure TRutisEngine.OpJmp; +Begin + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpJZ; +Var bool : Boolean; +Begin + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intBoolean, + intByte : Bool := ScriptData.Stack.PopByte = 0; + intWord : Bool := ScriptData.Stack.PopWord = 0; + intCardinal : Bool := ScriptData.Stack.PopCardinal = 0; + intShortInt : Bool := ScriptData.Stack.PopShortInt = 0; + intSmallint : Bool := ScriptData.Stack.PopSmallint = 0; + intInteger : Bool := ScriptData.Stack.PopInteger = 0; + intSingle : Bool := ScriptData.Stack.PopSingle = 0; + intDouble : Bool := ScriptData.Stack.PopDouble = 0; + intExtended : Bool := ScriptData.Stack.PopExtended = 0; + Else + Bool := False; + End; + If bool Then + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpJL; +Var bool : Boolean; +Begin + Bool := False; + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intBoolean : ScriptData.Stack.PopByte; + intWord : ScriptData.Stack.PopWord; + intCardinal : ScriptData.Stack.PopCardinal; + intShortInt : Bool := ScriptData.Stack.PopShortInt < 0; + intSmallint : Bool := ScriptData.Stack.PopSmallint < 0; + intInteger : Bool := ScriptData.Stack.PopInteger < 0; + intSingle : Bool := ScriptData.Stack.PopSingle < 0; + intDouble : Bool := ScriptData.Stack.PopDouble < 0; + intExtended : Bool := ScriptData.Stack.PopExtended < 0; + End; //} + If bool Then + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpJG; +Var bool : Boolean; +Begin + Bool := True; + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intBoolean : ScriptData.Stack.PopByte; + intWord : ScriptData.Stack.PopWord; + intCardinal : ScriptData.Stack.PopCardinal; + intShortInt : Bool := ScriptData.Stack.PopShortInt > 0; + intSmallint : Bool := ScriptData.Stack.PopSmallint > 0; + intInteger : Bool := ScriptData.Stack.PopInteger > 0; + intSingle : Bool := ScriptData.Stack.PopSingle > 0; + intDouble : Bool := ScriptData.Stack.PopDouble > 0; + intExtended : Bool := ScriptData.Stack.PopExtended > 0; + End; + If bool Then + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpJLZ; +Var bool : Boolean; +Begin + Bool := False; + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intBoolean : Bool := ScriptData.Stack.PopByte = 0; + intWord : Bool := ScriptData.Stack.PopWord = 0; + intCardinal : Bool := ScriptData.Stack.PopCardinal = 0; + intShortInt : Bool := ScriptData.Stack.PopShortInt <= 0; + intSmallint : Bool := ScriptData.Stack.PopSmallint <= 0; + intInteger : Bool := ScriptData.Stack.PopInteger <= 0; + intSingle : Bool := ScriptData.Stack.PopSingle <= 0; + intDouble : Bool := ScriptData.Stack.PopDouble <= 0; + intExtended : Bool := ScriptData.Stack.PopExtended <= 0; + End; //} + If bool Then + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpJGZ; +Var bool : Boolean; +Begin + Bool := True; + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intBoolean : ScriptData.Stack.PopByte; + intWord : ScriptData.Stack.PopWord; + intCardinal : ScriptData.Stack.PopCardinal; + intShortInt : Bool := ScriptData.Stack.PopShortInt >= 0; + intSmallint : Bool := ScriptData.Stack.PopSmallint >= 0; + intInteger : Bool := ScriptData.Stack.PopInteger >= 0; + intSingle : Bool := ScriptData.Stack.PopSingle >= 0; + intDouble : Bool := ScriptData.Stack.PopDouble >= 0; + intExtended : Bool := ScriptData.Stack.PopExtended >= 0; + End; + If bool Then + ScriptData.CodeLine := ScriptData.CurrCmd.P1 - 1; +End; + +Procedure TRutisEngine.OpOpr; +Var + Val1, Val2 : Variant; +Begin + Case TRutisIntType(ScriptData.CurrCmd.P3) Of + intByte, + intEnum : Val2 := ScriptData.Stack.PopByte; + intAChar : Val2 := ScriptData.Stack.PopByte; //PopAChar + intBoolean : Val2 := Boolean(ScriptData.Stack.PopByte); + intWord : Val2 := ScriptData.Stack.PopWord; + intCardinal, + intPointer, + intArray : Val2 := ScriptData.Stack.PopCardinal; + intAString : Val2 := Ansistring(ScriptData.Stack.PopString); + intShortInt : Val2 := ScriptData.Stack.PopShortInt; + intSmallint : Val2 := ScriptData.Stack.PopSmallint; + intInteger : Val2 := ScriptData.Stack.PopInteger; + intSingle : Val2 := ScriptData.Stack.PopSingle; + intDouble : Val2 := ScriptData.Stack.PopDouble; + intExtended : Val2 := ScriptData.Stack.PopExtended; + Else + ScriptMessage('Comparison Error'); + End; + + Case TRutisIntType(ScriptData.CurrCmd.P2) Of + intByte, + intEnum : Val1 := ScriptData.Stack.PopByte; + intAChar : Val1 := ScriptData.Stack.PopByte; //PopAChar + intBoolean : Val1 := Boolean(ScriptData.Stack.PopByte); + intWord : Val1 := ScriptData.Stack.PopWord; + intCardinal, + intPointer, + intArray : Val1 := ScriptData.Stack.PopCardinal; + intAString : Val1 := Ansistring(ScriptData.Stack.PopString); + intShortInt : Val1 := ScriptData.Stack.PopShortInt; + intSmallint : Val1 := ScriptData.Stack.PopSmallint; + intInteger : Val1 := ScriptData.Stack.PopInteger; + intSingle : Val1 := ScriptData.Stack.PopSingle; + intDouble : Val1 := ScriptData.Stack.PopDouble; + intExtended : Val1 := ScriptData.Stack.PopExtended; + Else + ScriptMessage('Comparison Error'); + End; + + Case TOperatorCode(ScriptData.CurrCmd.P1) Of + ocEqual : Val1 := (Val1 = Val2); + ocGreater : Val1 := (Val1 > Val2); + ocLess : Val1 := (Val1 < Val2); + ocGEqual : Val1 := (Val1 >= Val2); + ocLEqual : Val1 := (Val1 <= Val2); + ocUnequal : Val1 := (Val1 <> Val2); + End; + + ScriptData.Stack.PushByte(Byte(Boolean(Val1))); +End; + +{$ENDREGION} + +//=================================== +//============ RUN ================== +//=================================== + +Procedure TRutisEngine.ExecuteCMD(CMD : TRutisScriptCmd); +Begin + ScriptData.CurrCmd := CMD; + Case ScriptData.CurrCmd.Cmd Of + _gen : OpGen; + + _gen1 : OpGen1; + _gen2 : OpGen2; + _gen4 : OpGen4; + + _Ptr : OpPtr; + _PtrP : OpPtrP; + _CPtr : OpCheckPtr; + _at : OpAt; + _at2 : OpAt2; + + _lodR : OpLodR; + _RStr : OpResStr; + _lod : OpLod; + _sto : OpSto; + _mov : OpMov; + + _lodp : OpLodP; + _stop : OpStoP; + + _CopyAStr : OpCopyAStr; + _CopyWStr : OpCopyWStr; + _StoAStr : OpStoAStr; + _StoWStr : OpStoWStr; + + _SMem : OpScaleMem; + _MemS : OpMemSize; + + _GASL : OpGetAStrLength; + _SASL : OpSetAStrLength; + _GWSL : OpGetWStrLength; + _SWSL : OpSetWStrLength; + + _inc : OpInc; + + _conv : OpConv; + _add : OpAdd; + _sub : OpSub; + _mult : OpMult; + _div : OpDiv; + _mod : OpModulo; + _ets : OpEnumToSet; + + _call : OpCall; + _ret : OpRet; + + _jmp : OpJmp; + _opr : OpOpr; + _JZ : OpJZ; + _JL : OpJL; + _JG : OpJG; + _JLZ : OpJLZ; + _JGZ : OpJGZ; + + _and : OpAnd; + _or : OpOr; + _xor : OpXOr; + _not : OpNot; + + _wri : OpWri; + _ext : OpExt; + + _pupo : If ScriptData.CurrCmd.P1 >= 0 Then + ScriptData.Stack.Push(ScriptData.CurrCmd.P1) + Else + ScriptData.Stack.Pop(-ScriptData.CurrCmd.P1); + End; +End; + +Procedure TRutisEngine.ResetScriptState; +Begin + If ScriptData = nil Then exit; + ScriptData.Stack.Clear; + SetLength(ScriptData.CallStack, 0); + ScriptData.FreeExtData; + + ScriptData.CodeLine := 0; + ScriptData.Running := False; + ScriptData.Paused := False; + fScriptError := False; + + SetCurrentDir(ScriptFilePath); +End; + +Procedure TRutisEngine.Run; +Var + ProcessCount : Integer; +Begin + If ScriptData = nil Then exit; + If ScriptData.Running and not ScriptData.Paused Then + Begin + ScriptData.Running := False; + exit; + End; + If not ScriptData.Compiled Then + exit; + + If not ScriptData.Running Then + ResetScriptState; + + {$ifdef DEBUG}OutputDebugString('TRutisEngine.Run - Running Script');{$endif} + + ProcessCount := 0; + ScriptData.Running := True; + ScriptData.Paused := False; + Repeat + Inc(ProcessCount); + If OptProcessTimer and (ProcessCount > OptProcessTimerCount) Then + Begin + If Assigned(OnCodeTimer) Then + OnCodeTimer(self) + Else + Application.ProcessMessages; + ProcessCount := 0; + End; + If not ScriptData.Running or ScriptData.Paused Then break; + + If ScriptData.CodeLine > high(ScriptData.Code) Then exit; + ExecuteCMD(ScriptData.Code[ScriptData.CodeLine]); + ScriptData.CodeLine := ScriptData.CodeLine + 1; + + If GetBreakpointToCMD(ScriptData.CodeLine) > -1 Then + ScriptData.Paused := True; + + Until (ScriptData.CodeLine <= 0) or (ScriptData.CodeLine > high(ScriptData.Code)) or fScriptError; + + If fScriptError Then + Begin + ScriptData.Running := False; + exit; + {$ifdef DEBUG}OutputDebugString('TRutisEngine.Run - Error while running Script');{$endif} + End; + {$ifdef DEBUG} + If ScriptData.Paused Then + OutputDebugString('TRutisEngine.Run - Script paused') + Else + OutputDebugString('TRutisEngine.Run - Script stopped'); + {$endif} + + If (ScriptData.CodeLine <= 0) or (ScriptData.CodeLine > high(ScriptData.Code)) Then + ScriptData.Running := False; +End; + +Procedure TRutisEngine.Stop; +Begin + If ScriptData = nil Then exit; + ScriptData.Running := False; + ScriptData.Paused := False; +End; + +Procedure TRutisEngine.Pause; +Begin + If ScriptData = nil Then exit; + If not ScriptData.Running Then exit; + ScriptData.Paused := True; +End; + +Procedure TRutisEngine.StepCmd; +Begin + If ScriptData = nil Then exit; + If not ScriptData.Running Then + ResetScriptState; + ScriptData.Running := True; + ScriptData.Paused := True; + + {$ifdef DEBUG}OutputDebugString('TRutisEngine.StepCmd - Executing CMD');{$endif} + + If ScriptData.CodeLine > high(ScriptData.Code) Then exit; + ExecuteCMD(ScriptData.Code[ScriptData.CodeLine]); + ScriptData.CodeLine := ScriptData.CodeLine + 1; + + If fScriptError Then + Begin + ScriptData.Running := False; + exit; + End; + + If (ScriptData.CodeLine <= 0) or (ScriptData.CodeLine > high(ScriptData.Code)) Then + ScriptData.Running := False; +End; + +Procedure TRutisEngine.StepLine; +Var + LastCMD, + ProcessCount, + StartCodeLine : Integer; +Begin + If ScriptData = nil Then exit; + If not ScriptData.Running Then + ResetScriptState; + ScriptData.Running := True; + ScriptData.Paused := True; + + {$ifdef DEBUG}OutputDebugString('TRutisEngine.StepCmd - Executing Line');{$endif} + + StartCodeLine := ScriptData.Code[ScriptData.CodeLine].CodeLine; + LastCMD := ScriptData.CodeLine; + While True Do + Begin + If (ScriptData.Code[LastCMD].Cmd = _ret) Then + Begin + LastCMD := -1; + break; + End; + If (ScriptData.Code[LastCMD].Cmd = _call) Then + Begin + LastCMD := LastCMD + 1; + break; + End; + Inc(LastCMD); + If (ScriptData.Code[LastCMD].CodeLine <> StartCodeLine) Then + break; + End; + + ScriptData.Paused := False; + ProcessCount := 0; + Repeat + Inc(ProcessCount); + If OptProcessTimer and (ProcessCount > OptProcessTimerCount) Then + Begin + If Assigned(OnCodeTimer) Then + OnCodeTimer(self) + Else + Application.ProcessMessages; + ProcessCount := 0; + End; + + ExecuteCMD(ScriptData.Code[ScriptData.CodeLine]); + ScriptData.CodeLine := ScriptData.CodeLine + 1; + + If GetBreakpointToCMD(ScriptData.CodeLine) > -1 Then + ScriptData.Paused := True; + + Until (ScriptData.CodeLine <= 0) or + (ScriptData.CodeLine > high(ScriptData.Code)) or + fScriptError or + (ScriptData.CodeLine = LastCMD) or not ScriptData.Running or + ScriptData.Paused; + + ScriptData.Paused := True; + + If fScriptError Then + Begin + ScriptData.Running := False; + exit; + End; + + If (ScriptData.CodeLine <= 0) or + (ScriptData.CodeLine > high(ScriptData.Code)) Then + ScriptData.Running := False; +End; + +//=================================== + +Procedure TRutisEngine.ToggleBreakpoint(Line : Integer); +Var + i : Integer; +Begin + i := GetBreakpoint(Line); + If i > -1 Then + Begin + Breakpoints[i] := Breakpoints[high(Breakpoints)]; + SetLength(Breakpoints, length(Breakpoints) - 1); + {$ifdef DEBUG}OutputDebugString('TRutisEngine.ToggleBreakpoint - Breakpoint removed at line ' + IntToStr(Line));{$endif} + End + Else + Begin + SetLength(Breakpoints, length(Breakpoints) + 1); + Breakpoints[high(Breakpoints)].Line := Line; + {$ifdef DEBUG}OutputDebugString('TRutisEngine.ToggleBreakpoint - Breakpoint set at line ' + IntToStr(Line));{$endif} + End; +End; + +Function TRutisEngine.GetBreakpoint(Line : Integer) : Integer; +Begin + For Result := 0 To high(Breakpoints) Do + If Breakpoints[Result].Line = Line Then + exit; + Result := -1; +End; + +Function TRutisEngine.GetBreakpointToCmd(CMD : Integer) : Integer; +Begin + For Result := 0 To high(Breakpoints) Do + If (Breakpoints[Result].Line = ScriptData.Code[CMD].CodeLine) and + (ScriptData.Code[CMD - 1].CodeLine <> ScriptData.Code[CMD].CodeLine) Then + exit; + Result := -1; +End; + +//=================================== + +Function TRutisEngine.DebugVarValue(AVarDecl : TRutisVarDecl) : String; +Var + I, addr : Integer; +Begin + If not (AVarDecl is TRutisVarDecl) Then exit; + + If AVarDecl.Level = 0 Then + addr := AVarDecl.Address + Else + addr := GetStackLvlAddress(AVarDecl.Address, AVarDecl.Level); + + Result := ''; + If (AVarDecl.VarType is TRutisVarType) or + (AVarDecl.VarType is TRutisEnumType) or + (AVarDecl.VarType is TRutisMethodType) Then + Begin + If AVarDecl.isConst Then + Begin + If AVarDecl.VarType.InternalType = intAString Then + Begin + Result := PChar(ScriptData.Ressources.GetCardinal(Addr)); + End + Else + Result := ScriptData.Ressources.ReadToStr(AVarDecl.VarType.InternalType, Addr); + End + Else + Result := ScriptData.Stack.ReadToStr(AVarDecl.VarType.InternalType, Addr); + End + Else + If AVarDecl.VarType is TRutisStructType Then + With TRutisStructType(AVarDecl.VarType) Do + Begin + Result := '['; + For I := 0 To high(StructTypes) Do + Begin + If AVarDecl.isConst Then + Result := Result + + ScriptData.Ressources.ReadToStr(StructTypes[i].VarType.InternalType, Addr + StructTypes[i].Address) + Else + Result := Result + + ScriptData.Stack.ReadToStr(StructTypes[i].VarType.InternalType, Addr + StructTypes[i].Address); + + If i < high(StructTypes) Then + Result := Result + ','; + End; + Result := Result + ']'; + End + Else + If AVarDecl.VarType is TRutisPointerType Then + Begin + If AVarDecl.isConst Then + Result := '@' + ScriptData.Ressources.ReadToStr(AVarDecl.VarType.InternalType, Addr) + Else + Result := '@' + ScriptData.Stack.ReadToStr(AVarDecl.VarType.InternalType, Addr); + {try + except + end;} + End + Else + If AVarDecl.VarType is TRutisArrayType Then + Begin + If AVarDecl.isConst Then + Result := '@' + ScriptData.Ressources.ReadToStr(AVarDecl.VarType.InternalType, Addr) + Else + Result := '@' + ScriptData.Stack.ReadToStr(AVarDecl.VarType.InternalType, Addr); + End; +End; + +Function TRutisEngine.DebugVarName(AVarDecl : TRutisVarDecl) : String; +Begin + If AVarDecl.VarType is TRutisArrayType Then + Result := 'Array of ' + TRutisArrayType(AVarDecl.VarType).ArrayType.Name + + Else If AVarDecl.VarType is TRutisPointerType Then + Result := '^' + TRutisPointerType(AVarDecl.VarType).PointerType.Name + + Else If AVarDecl.VarType is TRutisExtMethodType Then + Begin + If TRutisMethodType(AVarDecl.VarType).IsFunction Then + Result := 'Function ' + Else + Result := 'Procedure '; + //Result := '^' + TRutisPointerType(AVarDecl.VarType).PointerType.Name + End + + Else If AVarDecl.VarType is TRutisMethodType Then + Begin + If TRutisMethodType(AVarDecl.VarType).IsFunction Then + Result := 'Ext-Function ' + Else + Result := 'Ext-Procedure '; + //Result := '^' + TRutisPointerType(AVarDecl.VarType).PointerType.Name + End + Else + Result := AVarDecl.VarType.Name; +End; + +//============================================================================== +//======================= Compiler ============================================= +//============================================================================== + +{$ifdef FPC} +function LoadLibraryA(lpLibFileName: LPCSTR): HINST; external KernelDLL name 'LoadLibraryA'; +{$endif FPC} + +Function TRutisEngine.RegisterExtDll(FileName : String) : Boolean; +Var i : Integer; +Begin + Result := False; + + If not FileExists(FileName) Then exit; + + i := length(fExtDlls); + SetLength(fExtDlls, i + 1); + + fExtDlls[i].DllHandle := LoadLibraryA(PAnsiChar(FileName)); + + If fExtDlls[i].DllHandle = 0 Then + Begin + SetLength(fExtDlls, i); + exit; + End; + + With fExtDlls[i] Do + Begin + RegisterEXTMethods := TRegisterEXTMethods(GetProcAddress(DllHandle, 'RegisterEXTMethods')); + StartScript := TScriptAction(GetProcAddress(DllHandle, 'StartScript')); + StopScript := TScriptAction(GetProcAddress(DllHandle, 'StopScript')); + PauseScript := TScriptAction(GetProcAddress(DllHandle, 'PauseScript')); + Destroy := TScriptAction(GetProcAddress(DllHandle, 'Destroy')); + End; + + fExtDlls[i].RegisterEXTMethods(self); + + Result := True; +End; + +Procedure TRutisEngine.UnloadExtDlls; +Var i : Integer; +Begin + For i := 0 To high(fExtDlls) Do + FreeLibrary(fExtDlls[i].DllHandle); + SetLength(fExtDlls, 0); +End; + +//============================================================================== + +Procedure TRutisEngine.GetByteCode(ByteCode : TStrings); +Var + i, pos : Integer; + s : String; + ValSingle : Boolean; + sng : Single; +Begin + SetLength(ScriptData.Code, 0); + For i := 0 To ByteCode.Count - 1 Do + Begin + If length(ByteCode.Strings[i]) = 0 Then + continue; + If (ByteCode.Strings[i][1] = '/') and (ByteCode.Strings[i][2] = '/') Then + continue; + s := ''; + pos := 1; + While (ByteCode.Strings[i][pos] <> ' ') and (pos <= length(ByteCode.Strings[i])) Do + Begin + s := s + ByteCode.Strings[i][pos]; + Inc(pos); + End; + + SetLength(ScriptData.Code, Length(ScriptData.Code) + 1); + With ScriptData.Code[high(ScriptData.Code)] Do + Begin + Cmd := StrToSym(s); + If Cmd = _nocmd Then + Begin + ScriptMessage('Error reading ByteCode in line ' + IntToStr(i)); + exit; + End; + End; + + If pos >= length(ByteCode.Strings[i]) Then + continue; + + s := ''; + While (ByteCode.Strings[i][pos] = ' ') and (pos < length(ByteCode.Strings[i])) Do + Inc(pos); + If pos > length(ByteCode.Strings[i]) Then + continue; + Repeat + s := s + ByteCode.Strings[i][pos]; + Inc(pos); + Until (ByteCode.Strings[i][pos] = ' ') or (pos > length(ByteCode.Strings[i])); + + ScriptData.Code[high(ScriptData.Code)].P1 := StrToInt(s); + If pos > length(ByteCode.Strings[i]) Then + continue; + + s := ''; + ValSingle := False; + While (ByteCode.Strings[i][pos] = ' ') and (pos < length(ByteCode.Strings[i])) Do + Inc(pos); + If pos > length(ByteCode.Strings[i]) Then + continue; + Repeat + s := s + ByteCode.Strings[i][pos]; + If ByteCode.Strings[i][pos] = ',' Then + ValSingle := True; + Inc(pos); + Until (ByteCode.Strings[i][pos] = ' ') or (pos > length(ByteCode.Strings[i])); + If ValSingle Then + Begin + sng := StrToFloat(s); + ScriptData.Code[high(ScriptData.Code)].P2 := PInteger(@sng)^; + End + Else + ScriptData.Code[high(ScriptData.Code)].P2 := StrToInt(s); + End; +End; + +//============================================================================== + +Function TRutisEngine.ExtMethodLinkToStr(ExtLink : TRutisExtMethodType; IncludeProc : Boolean) : String; +Var + i : Integer; +Begin + Result := ''; + If IncludeProc Then + Begin + If ExtLink.IsFunction Then + Result := 'Function ' + Else + Result := 'Procedure '; + End; + Result := Result + ExtLink.Method_Name; + + If length(ExtLink.Params) > 0 Then + Begin + Result := Result + ' ('; + + // For i := 0 To high(ExtLink.Params) - 1 Do + // Result := Result + ExtLink.Params[i].Name + '; '; + // Result := Result + ExtLink.Params[high(ExtLink.Params)].Name; + For i := 0 To high(ExtLink.Params) - 1 Do + Result := Result + ExtLink.Params[i].Name + '; '; + Result := Result + ExtLink.Params[high(ExtLink.Params)].Name; + + Result := Result + ')'; + End; + + If ExtLink.IsFunction Then + Result := Result + ': ' + ExtLink.MethodResult.Name + ';' + Else + Result := Result + ';'; +End; + +Function TRutisEngine.ShowExtMethodListWindow : TRutisExtMethodType; +Var + Win : TFExtMethodListInfo; + i : Integer; +Begin + Result := nil; + Win := nil; + Try + Win := TFExtMethodListInfo.Create(nil); + Win.Hide; + + For i := 0 To high(StaticDeclarations) Do + If StaticDeclarations[i] is TRutisExtMethodType Then + Begin + SetLength(Win.ExtMethods, length(Win.ExtMethods) + 1); + Win.ExtMethods[high(Win.ExtMethods)].ExtMethodType := StaticDeclarations[i]; + Win.ExtMethods[high(Win.ExtMethods)].Name := ExtMethodLinkToStr(TRutisExtMethodType(StaticDeclarations[i]), False); + Win.ExtMethods[high(Win.ExtMethods)].Description := TRutisExtMethodType(StaticDeclarations[i]).Description; + Win.ExtMethods[high(Win.ExtMethods)].IsFunction := TRutisExtMethodType(StaticDeclarations[i]).IsFunction; + End; + + Win.ShowModal; + Result := TRutisExtMethodType(Win.ResultExtMethod); + + Finally + Win.Free; + End; +End; + +//============================================================================== + + +End. + diff --git a/Units/RUTIS/Rutis_ExtDll_OpenGl.pas b/Units/RUTIS/Rutis_ExtDll_OpenGl.pas new file mode 100644 index 0000000..65b2db8 --- /dev/null +++ b/Units/RUTIS/Rutis_ExtDll_OpenGl.pas @@ -0,0 +1,1028 @@ +Unit Rutis_ExtDll_OpenGl; + +Interface + +Uses + Windows, Controls, SysUtils, + Rutis_Engine, Rutis_Defs, + dglOpenGl, + TFrustumClass, + OpenGl_Texture_Manager, + OpenGl_Types, + OpenGl_Functions, + OpenGl_Speed_Lists; + +Var + Rogl_Display : TWinControl; + Rogl_DC, Rogl_RC : HDC; + Rogl_CamPos, + Rogl_CamRot : TVector3f; + Rogl_NearClipping, + Rogl_FarClipping : Single; + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Procedure ROgl_SetViewport(WinControl : TWinControl); +Procedure DestroyRoglContext; +Procedure ResizeRoglContext; + +Implementation + +Var + ROGL_Width, ROGL_Height : Integer; + //============================================================================== + //============================================================================== + +Function CreateContext : Integer; +Begin + If not InitOpenGl Then exit; + Result := CreateRenderingContext(Rogl_DC, [opDoubleBuffered], 32, 24, 0, 32, 0, 0); +End; + +Procedure DestroyRoglContext; +Begin + SetLength(TexManager_TexturePaths, 0); + AddTexturePath('.\'); + AddTexturePath(ExtractFileDir(ParamStr(0))); + FreeTextures; + DeleteSpeedLists; + Rogl_NearClipping := 1; + Rogl_FarClipping := 1000; + If Rogl_DC <> 0 Then + Begin + If Rogl_RC <> 0 Then + Begin + DeactivateRenderingContext; + DestroyRenderingContext(Rogl_RC); + Rogl_RC := 0; + End; + Try + ReleaseDC(Rogl_Display.Handle, Rogl_DC); + Except + End; + Rogl_DC := 0; + Rogl_CamPos := nullvect; + Rogl_CamRot := nullvect; + sleep(1); + End; +End; + +Procedure ResizeRoglContext; +Begin + If (Rogl_DC <> 0) and (Rogl_RC <> 0) Then + Begin + glViewport(0, 0, Rogl_Display.Width, Rogl_Display.Height); + {glMatrixMode(GL_PROJECTION); + glLoadIdentity; + gluPerspective(45.0, ClientWidth/ClientHeight, NearClipping, FarClipping); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity;} + End; +End; + +Procedure ROgl_SetViewport(WinControl : TWinControl); +Begin + If not (WinControl is TWinControl) Then exit; + Rogl_Display := WinControl; + + DestroyRoglContext; + + If not (Rogl_Display is TWinControl) Then + Rogl_Display := Rogl_Display.Parent; + + Rogl_DC := GetDC(Rogl_Display.Handle); + Rogl_RC := CreateContext; + ActivateRenderingContext(Rogl_DC, Rogl_RC); + + sleep(1); + + glClearColor(0, 0, 0, 0); + glEnable(GL_DEPTH_TEST); + glEnable(GL_CULL_FACE); +End; + +//============================================================================== +//============================================================================== +{$REGION 'gl-Extension glx'} + +Procedure _glxSetViewportControl(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + ROgl_SetViewport(TWinControl(PPointer(Params^[0].Data)^)); +End; + +Procedure _InitOpenGL(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If Rogl_Display = nil Then exit; + + DestroyRoglContext; + + Rogl_DC := GetDC(Rogl_Display.Handle); + //If not InitOpenGl then exit; + Rogl_RC := CreateContext; + ActivateRenderingContext(Rogl_DC, Rogl_RC); + + sleep(1); + + glClearColor(0, 0, 0, 0); + glEnable(GL_DEPTH_TEST); + glEnable(GL_COLOR_MATERIAL); + glEnable(GL_CULL_FACE); +End; + +Procedure _glxNewFrame(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + If Rogl_RC = 0 Then _InitOpenGL(nil, nil, nil); + If Rogl_RC = 0 Then exit; + + SwapBuffers(Rogl_DC); + + If (Rogl_Display.Width <> ROGL_Width) or (Rogl_Display.Height <> ROGL_Height) Then + Begin + ROGL_Width := Rogl_Display.Width; + ROGL_Width := Rogl_Display.Height; + glViewport(0, 0, Rogl_Display.Width, Rogl_Display.Height); + End; + + glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); + + glMatrixMode(GL_PROJECTION); + glLoadIdentity; + gluPerspective(45.0, Rogl_Display.Width / Rogl_Display.Height, Rogl_NearClipping, Rogl_FarClipping); + glMatrixMode(GL_MODELVIEW); + glLoadIdentity; + + glRotateV(Vector(-Rogl_CamRot.X, -Rogl_CamRot.Y, -Rogl_CamRot.Z)); + glTranslatef(-Rogl_CamPos.X, -Rogl_CamPos.Y, -Rogl_CamPos.Z); +End; + +Procedure _glxSwapBuffers(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + SwapBuffers(Rogl_DC); +End; + +Procedure _glxSetNearFarClipping(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_NearClipping := PSingle(Params^[0].Data)^; + Rogl_FarClipping := PSingle(Params^[1].Data)^; +End; + +Procedure _glxGetTexture(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PInteger(Result^.Data)^ := ApplyTexture(PAnsiString(Params^[0].Data)^, False); +End; + +Procedure _glxApplyTexture(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + ApplyTexture(PAnsiString(Params^[0].Data)^); +End; + +Procedure _glxCamPos(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_CamPos.X := PSingle(Params^[0].Data)^; + Rogl_CamPos.Y := PSingle(Params^[1].Data)^; + Rogl_CamPos.Z := PSingle(Params^[2].Data)^; +End; + +Procedure _glxCamRot(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Rogl_CamRot.X := PSingle(Params^[0].Data)^; + Rogl_CamRot.Y := PSingle(Params^[1].Data)^; + Rogl_CamRot.Z := PSingle(Params^[2].Data)^; +End; + +Procedure _glxCalculateFrustum(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + Frustum.Calculate; +End; + +Procedure _glxIsPointInFrustum(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsPointWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glxIsSphereInFrustum(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsSphereWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glxIsBoxInFrustum(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsBoxWithin( + PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + PSingle(Params^[5].Data)^); +End; + +Procedure _glxIsPointInFrustumV(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsPointWithin( + PVector3f(Params^[0].Data)^.x, + PVector3f(Params^[0].Data)^.y, + PVector3f(Params^[0].Data)^.z); +End; + +Procedure _glxIsSphereInFrustumV(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsSphereWithin( + PPVector3f(Params^[0].Data)^^.x, + PPVector3f(Params^[0].Data)^^.y, + PPVector3f(Params^[0].Data)^^.z, + PSingle(Params^[1].Data)^); +End; + +Procedure _glxIsBoxInFrustumV(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PBoolean(Result^.Data)^ := Frustum.IsBoxWithin( + PVector3f(Params^[0].Data)^.x, + PVector3f(Params^[0].Data)^.y, + PVector3f(Params^[0].Data)^.z, + PVector3f(Params^[1].Data)^.x, + PVector3f(Params^[1].Data)^.y, + PVector3f(Params^[1].Data)^.z); +End; + +{$ENDREGION} + +//============================================================================== + +Procedure _glViewport(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glViewport(PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, PInteger(Params^[2].Data)^, PInteger(Params^[3].Data)^); +End; + +Procedure _glClear(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glClear(PCardinal(Params^[0].Data)^); +End; + +Procedure _glFlush(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glFlush; +End; + +//============================================================================== + +Procedure _glGenLists(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + PCardinal(Result^.Data)^ := glGenLists(PCardinal(Params^[0].Data)^); +End; + +Procedure _glNewList(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNewList(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^); +End; + +Procedure _glEndList(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEndList; +End; + +Procedure _glCallList(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glCallList(PCardinal(Params^[0].Data)^); +End; + +//============================================================================== +{$REGION 'Textures'} + +Procedure _glGenTextures(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glGenTextures(PInteger(Params^[0].Data)^, PGLUInt(Params^[1].Data)); +End; + +Procedure _glBindTexture(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBindTexture(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^); +End; + +Procedure _glTexImage2D(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexImage2D(PCardinal(Params^[0].Data)^, PInteger(Params^[1].Data)^, PInteger(Params^[2].Data)^, + PInteger(Params^[3].Data)^, PInteger(Params^[4].Data)^, PCardinal(Params^[5].Data)^, + PCardinal(Params^[6].Data)^, PCardinal(Params^[7].Data)^, PPointer(Params^[8].Data)^); +End; + +Procedure _glCopyTexImage2d(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glCopyTexImage2d(PCardinal(Params^[0].Data)^, PInteger(Params^[1].Data)^, PCardinal(Params^[2].Data)^, + PInteger(Params^[3].Data)^, PInteger(Params^[4].Data)^, PInteger(Params^[5].Data)^, PInteger(Params^[6].Data)^, + PInteger(Params^[7].Data)^); +End; + +Procedure _glTexParameteri(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexParameteri(PCardinal(Params^[0].Data)^, PCardinal(Params^[1].Data)^, PInteger(Params^[2].Data)^); +End; + +{$ENDREGION} + +//============================================================================== + +Procedure _glEnable(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEnable(PInteger(Params^[0].Data)^); +End; + +Procedure _glDisable(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glDisable(PInteger(Params^[0].Data)^); +End; + +//============================================================================== + +Procedure _glPushAttrib(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPushAttrib(PInteger(Params^[0].Data)^); +End; + +Procedure _glPopAttrib(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPopAttrib; +End; + +//============================================================================== +{$REGION 'Vectors etc.'} + +Procedure _glColor3f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glColor3fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glColor4f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor4f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glColor4fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glColor4fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glVertex2f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex2f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^); +End; + +Procedure _glVertex2fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex2fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glVertex3f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glVertex3fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glVertex4f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex4f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glVertex4fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glVertex4fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glNormal3f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNormal3f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glNormal3fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glNormal3fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +//============================================================================== + +Procedure _glTexCoord2f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexCoord2f(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^); +End; + +Procedure _glTexCoord2fv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTexCoord2fv(PGLFloat(PPointer(Params^[0].Data)^)); +End; + +{$ENDREGION} + +//============================================================================== + +Procedure _glBegin(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBegin(PInteger(Params^[0].Data)^); +End; + +Procedure _glEnd(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glEnd; +End; + +Procedure _glSphere(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + slSphere(PInteger(Params^[0].Data)^{,Params^[1]}); +End; + +Procedure _glCube(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + slCube(1, 1, 1, PInteger(Params^[0].Data)^); +End; + +//============================================================================== +{$REGION 'Matrix'} + +Procedure _glMatrixMode(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glMatrixMode(PCardinal(Params^[0].Data)^); +End; + +Procedure _glOrtho(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glOrtho(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, PSingle(Params^[5].Data)^); +End; + +Procedure _gluOrtho2D(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + gluOrtho2D(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +Procedure _gluPerspective(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + gluPerspective(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +Procedure _glPushMatrix(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPushMatrix; +End; + +Procedure _glPopMatrix(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glPopMatrix; +End; + +Procedure _glLoadIdentity(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLoadIdentity; +End; + +//============================================================================== + +Procedure _glTranslatef(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTranslatef(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glTranslatefv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glTranslatef(PPVector3f(Params^[0].Data)^^.X, + PPVector3f(Params^[0].Data)^^.Y, + PPVector3f(Params^[0].Data)^^.Z); +End; + +//============================================================================== + +Procedure _glRotatef(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PSingle(Params^[0].Data)^, PSingle(Params^[1].Data)^, PSingle(Params^[2].Data)^, PSingle(Params^[3].Data)^); +End; + +Procedure _glRotate3f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PSingle(Params^[0].Data)^, 1, 0, 0); + glRotatef(PSingle(Params^[1].Data)^, 0, 1, 0); + glRotatef(PSingle(Params^[2].Data)^, 0, 0, 1); +End; + +Procedure _glRotatefv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glRotatef(PPVector3f(Params^[0].Data)^^.X, 1, 0, 0); + glRotatef(PPVector3f(Params^[0].Data)^^.Y, 0, 1, 0); + glRotatef(PPVector3f(Params^[0].Data)^^.Z, 0, 0, 1); +End; + +//============================================================================== + +Procedure _glScalef(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glScalef(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^); +End; + +Procedure _glScalefv(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glScalef(PPVector3f(Params^[0].Data)^^.X, + PPVector3f(Params^[0].Data)^^.Y, + PPVector3f(Params^[0].Data)^^.Z); +End; + +{$ENDREGION} + +//============================================================================== + +Procedure _glLight4f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var + vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + PSingle(Params^[5].Data)^); + glLightfv({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, @vec4f); +End; + +Procedure _glLight3f(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Var vec4f : TVector4f; +Begin + vec4f := Vector(PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^, + PSingle(Params^[4].Data)^, + 1); + glLightfv({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, @vec4f); +End; + +Procedure _glLightf(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLightf({GL_LIGHT0 + }PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^, PSingle(Params^[2].Data)^); +End; + +//============================================================================== + +Procedure _glLineWidth(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glLineWidth(PInteger(Params^[0].Data)^); +End; + +Procedure _glBlendFunc(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glBlendFunc(PInteger(Params^[0].Data)^, PInteger(Params^[1].Data)^); +End; + +Procedure _glClearColor(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glClearColor(PSingle(Params^[0].Data)^, + PSingle(Params^[1].Data)^, + PSingle(Params^[2].Data)^, + PSingle(Params^[3].Data)^); +End; + +Procedure _glAccum(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glAccum(PCardinal(Params^[0].Data)^, PSingle(Params^[1].Data)^); +End; + +Procedure _glReadBuffer(Stack : TRutisStack; Params : PRutisParamInfoArray; Result : PRutisParamInfo); +Begin + glReadBuffer(PCardinal(Params^[0].Data)^); +End; + +//============================================================================== +//============================================================================== + +Procedure RegisterEXTMethods(Engine : TRutisEngine); +Var + Decl : TRutisStructType; + Decl2 : TRutisPointerType; +Begin + OutputDebugString(PChar('Rutis_EXT_OpenGl.RegisterEXTMethods - Registering RUTIS OpenGL Support')); + //LOZ_Scripting.RegisterEXTMethods(@RutisEngine.MethodList); + + {$REGION 'Types'} + Decl := TRutisStructType.Create; + Decl.Name := 'TVector2f'; + Decl.IsPacked := True; + Decl.Size := 8; + Decl.fAlignSize := 4; + SetLength(Decl.StructTypes, 2); + Decl.StructTypes[0] := TRutisVarDecl.Create; + Decl.StructTypes[0].Name := 'X'; + Decl.StructTypes[0].Address := 0; + Decl.StructTypes[0].Level := 0; + Decl.StructTypes[0].VarType := TRutisTypeDecl(FindDeclaration('Single', @Engine.StaticDeclarations)); + Decl.StructTypes[1] := TRutisVarDecl.Create; + Decl.StructTypes[1].Name := 'Y'; + Decl.StructTypes[1].Address := 4; + Decl.StructTypes[1].Level := 0; + Decl.StructTypes[1].VarType := Decl.StructTypes[0].VarType; + Engine.AddStaticDeclaration(Decl); + + Decl2 := TRutisPointerType.Create; + Decl2.Name := 'PVector2f'; + Decl2.PointerType := Decl; + Engine.AddStaticDeclaration(Decl2); + + Decl := TRutisStructType.Create; + Decl.Name := 'TVector3f'; + Decl.IsPacked := True; + Decl.Size := 12; + Decl.fAlignSize := 4; + SetLength(Decl.StructTypes, 3); + Decl.StructTypes[0] := TRutisVarDecl.Create; + Decl.StructTypes[0].Name := 'X'; + Decl.StructTypes[0].Address := 0; + Decl.StructTypes[0].Level := 0; + Decl.StructTypes[0].VarType := TRutisTypeDecl(FindDeclaration('Single', @Engine.StaticDeclarations)); + Decl.StructTypes[1] := TRutisVarDecl.Create; + Decl.StructTypes[1].Name := 'Y'; + Decl.StructTypes[1].Address := 4; + Decl.StructTypes[1].Level := 0; + Decl.StructTypes[1].VarType := Decl.StructTypes[0].VarType; + Decl.StructTypes[2] := TRutisVarDecl.Create; + Decl.StructTypes[2].Name := 'Z'; + Decl.StructTypes[2].Address := 8; + Decl.StructTypes[2].Level := 0; + Decl.StructTypes[2].VarType := Decl.StructTypes[0].VarType; + Engine.AddStaticDeclaration(Decl); + + Decl2 := TRutisPointerType.Create; + Decl2.Name := 'PVector3f'; + Decl2.PointerType := Decl; + Engine.AddStaticDeclaration(Decl2); + + Decl := TRutisStructType.Create; + Decl.Name := 'TVector4f'; + Decl.IsPacked := True; + Decl.Size := 16; + Decl.fAlignSize := 4; + SetLength(Decl.StructTypes, 4); + Decl.StructTypes[0] := TRutisVarDecl.Create; + Decl.StructTypes[0].Name := 'X'; + Decl.StructTypes[0].Address := 0; + Decl.StructTypes[0].Level := 0; + Decl.StructTypes[0].VarType := TRutisTypeDecl(FindDeclaration('Single', @Engine.StaticDeclarations)); + Decl.StructTypes[1] := TRutisVarDecl.Create; + Decl.StructTypes[1].Name := 'Y'; + Decl.StructTypes[1].Address := 4; + Decl.StructTypes[1].Level := 0; + Decl.StructTypes[1].VarType := Decl.StructTypes[0].VarType; + Decl.StructTypes[2] := TRutisVarDecl.Create; + Decl.StructTypes[2].Name := 'Z'; + Decl.StructTypes[2].Address := 8; + Decl.StructTypes[2].Level := 0; + Decl.StructTypes[2].VarType := Decl.StructTypes[0].VarType; + Decl.StructTypes[3] := TRutisVarDecl.Create; + Decl.StructTypes[3].Name := 'W'; + Decl.StructTypes[3].Address := 12; + Decl.StructTypes[3].Level := 0; + Decl.StructTypes[3].VarType := Decl.StructTypes[0].VarType; + Engine.AddStaticDeclaration(Decl); + + Decl2 := TRutisPointerType.Create; + Decl2.Name := 'PVector4f'; + Decl2.PointerType := Decl; + Engine.AddStaticDeclaration(Decl2); + {$ENDREGION} + + //============================================================================== + //====================== OPENGL ================================================ + //============================================================================== + + {$REGION 'gl-Extension glx'} + Engine.RegExtMethod('glxInitOpenGL',{$IfDef FPC}@{$EndIf}_InitOpenGL, [], ''); + Engine.RegExtMethod('glxSetViewportControl',{$IfDef FPC}@{$EndIf}_glxSetViewportControl, ['Pointer'], ''); + Engine.RegExtMethod('glxNewFrame',{$IfDef FPC}@{$EndIf}_glxNewFrame, [], ''); + Engine.RegExtMethod('glxSwapBuffers',{$IfDef FPC}@{$EndIf}_glxSwapBuffers, [], ''); + Engine.RegExtMethod('glxSetNearFarClipping',{$IfDef FPC}@{$EndIf}_glxSetNearFarClipping, ['Single', 'Single'], ''); + Engine.RegExtMethod('glxApplyTexture',{$IfDef FPC}@{$EndIf}_glxApplyTexture, ['String'], ''); + Engine.RegExtMethod('glxGetTexture',{$IfDef FPC}@{$EndIf}_glxGetTexture, ['String'], 'Integer'); + Engine.RegExtMethod('glxCamPos',{$IfDef FPC}@{$EndIf}_glxCamPos, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glxCamRot',{$IfDef FPC}@{$EndIf}_glxCamRot, ['Single', 'Single', 'Single'], ''); + + Engine.RegExtMethod('glxCalculateFrustum',{$IfDef FPC}@{$EndIf}_glxCalculateFrustum, [], ''); + Engine.RegExtMethod('glxIsPointInFrustum',{$IfDef FPC}@{$EndIf}_glxIsPointInFrustum, ['Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak); + Engine.RegExtMethod('glxIsSphereInFrustum',{$IfDef FPC}@{$EndIf}_glxIsSphereInFrustum, ['Single', 'Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak + + '#4: Radius' + sLineBreak); + Engine.RegExtMethod('glxIsBoxInFrustum',{$IfDef FPC}@{$EndIf}_glxIsBoxInFrustum, ['Single', 'Single', 'Single', 'Single', 'Single', 'Single'], 'Boolean', + '#1: X' + sLineBreak + + '#2: Y' + sLineBreak + + '#3: Z' + sLineBreak + + '#4: X' + sLineBreak + + '#5: Size-Y' + sLineBreak + + '#6: Size-Z' + sLineBreak); + Engine.RegExtMethod('glxIsPointInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsPointInFrustumV, ['PVector3f'], 'Boolean', + '#1: XYZ' + sLineBreak); + Engine.RegExtMethod('glxIsSphereInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsSphereInFrustumV, ['PVector3f', 'Single'], 'Boolean', + '#1: XYZ' + sLineBreak + + '#2: Radius' + sLineBreak); + Engine.RegExtMethod('glxIsBoxInFrustumV',{$IfDef FPC}@{$EndIf}_glxIsBoxInFrustumV, ['PVector3f', 'PVector3f'], 'Boolean', + '#1: XYZ' + sLineBreak + + '#2: Size-XYZ'); + {$ENDREGION} + + Engine.RegExtMethod('glViewport',{$IfDef FPC}@{$EndIf}_glViewport, ['Integer', 'Integer', 'Integer', 'Integer'], ''); + Engine.RegExtMethod('glClear',{$IfDef FPC}@{$EndIf}_glClear, ['Cardinal'], ''); + Engine.RegExtMethod('glFlush',{$IfDef FPC}@{$EndIf}_glFlush, [], ''); + + Engine.RegExtMethod('glGenLists',{$IfDef FPC}@{$EndIf}_glGenLists, ['Cardinal'], 'Cardinal'); + Engine.RegExtMethod('glNewList',{$IfDef FPC}@{$EndIf}_glNewList, ['Cardinal', 'Cardinal'], ''); + Engine.RegExtMethod('glEndList',{$IfDef FPC}@{$EndIf}_glEndList, [], ''); + Engine.RegExtMethod('glCallList',{$IfDef FPC}@{$EndIf}_glCallList, ['Cardinal'], ''); + + Engine.RegExtMethod('glGenTextures',{$IfDef FPC}@{$EndIf}_glGenTextures, ['Cardinal', 'PCardinal'], ''); + Engine.RegExtMethod('glBindTexture',{$IfDef FPC}@{$EndIf}_glBindTexture, ['Cardinal', 'Cardinal'], ''); + Engine.RegExtMethod('glTexImage2D',{$IfDef FPC}@{$EndIf}_glTexImage2D, ['Cardinal', 'Integer', + 'Integer', 'Integer', 'Integer', 'Cardinal', 'Cardinal', 'Cardinal', 'Pointer'], ''); + Engine.RegExtMethod('glCopyTexImage2d',{$IfDef FPC}@{$EndIf}_glCopyTexImage2d, ['Cardinal', 'Integer', + 'Cardinal', 'Integer', 'Integer', 'Integer', 'Integer', 'Integer'], ''); + Engine.RegExtMethod('glTexParameteri',{$IfDef FPC}@{$EndIf}_glTexParameteri, ['Cardinal', 'Cardinal', 'Integer'], ''); + + Engine.RegExtMethod('glEnable',{$IfDef FPC}@{$EndIf}_glEnable, ['Integer'], ''); + Engine.RegExtMethod('glDisable',{$IfDef FPC}@{$EndIf}_glDisable, ['Integer'], ''); + Engine.RegExtMethod('glPushAttrib',{$IfDef FPC}@{$EndIf}_glPushAttrib, ['Integer'], ''); + Engine.RegExtMethod('glPopAttrib',{$IfDef FPC}@{$EndIf}_glPopAttrib, [], ''); + + {$REGION 'Vectors etc.'} + Engine.RegExtMethod('glColor3f',{$IfDef FPC}@{$EndIf}_glColor3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glColor4f',{$IfDef FPC}@{$EndIf}_glColor4f, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glColor3fv',{$IfDef FPC}@{$EndIf}_glColor3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glColor4fv',{$IfDef FPC}@{$EndIf}_glColor3fv, ['PVector4f'], ''); + Engine.RegExtMethod('glVertex2f',{$IfDef FPC}@{$EndIf}_glVertex2f, ['Single', 'Single'], ''); + Engine.RegExtMethod('glVertex3f',{$IfDef FPC}@{$EndIf}_glVertex3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glVertex4f',{$IfDef FPC}@{$EndIf}_glVertex4f, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glVertex2fv',{$IfDef FPC}@{$EndIf}_glVertex2fv, ['PVector2f'], ''); + Engine.RegExtMethod('glVertex3fv',{$IfDef FPC}@{$EndIf}_glVertex3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glVertex4fv',{$IfDef FPC}@{$EndIf}_glVertex4fv, ['PVector4f'], ''); + Engine.RegExtMethod('glNormal3f',{$IfDef FPC}@{$EndIf}_glNormal3f, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glNormal3fv',{$IfDef FPC}@{$EndIf}_glNormal3fv, ['PVector3f'], ''); + Engine.RegExtMethod('glTexCoord2f',{$IfDef FPC}@{$EndIf}_glTexCoord2f, ['Single', 'Single'], ''); + Engine.RegExtMethod('glTexCoord2fv',{$IfDef FPC}@{$EndIf}_glTexCoord2fv, ['PVector2f'], ''); + {$ENDREGION} + + Engine.RegExtMethod('glBegin',{$IfDef FPC}@{$EndIf}_glBegin, ['Integer'], ''); + Engine.RegExtMethod('glEnd',{$IfDef FPC}@{$EndIf}_glEnd, [], ''); + Engine.RegExtMethod('glSphere',{$IfDef FPC}@{$EndIf}_glSphere, ['Integer'], ''); + Engine.RegExtMethod('glCube',{$IfDef FPC}@{$EndIf}_glCube, ['Integer'], ''); + + //Engine.RegExtMethod('glFogf',{$IfDef FPC}@{$EndIf}_glFogf, ['Single'], ''); + //Engine.RegExtMethod('glFog4f',{$IfDef FPC}@{$EndIf}_glFog4f, ['Single','Single','Single','Single'], ''); + //Engine.RegExtMethod('glMaterialf',{$IfDef FPC}@{$EndIf}_glMaterialf, ['Single'], ''); + //Engine.RegExtMethod('glMaterial4f',{$IfDef FPC}@{$EndIf}_glMaterial4f, ['Single','Single','Single','Single'], ''); + + // MATRIX Operations + Engine.RegExtMethod('glMatrixMode',{$IfDef FPC}@{$EndIf}_glMatrixMode, ['Cardinal'], ''); + Engine.RegExtMethod('glOrtho',{$IfDef FPC}@{$EndIf}_glOrtho, ['Single', 'Single', 'Single', 'Single', 'Single', 'Single'], '', + 'procedure glOrtho(left, right, bottom, top, zNear, zFar: Single);'); + Engine.RegExtMethod('gluOrtho2D',{$IfDef FPC}@{$EndIf}_gluOrtho2D, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure gluOrtho2D(left, right, bottom, top: Single);'); + Engine.RegExtMethod('gluPerspective',{$IfDef FPC}@{$EndIf}_gluPerspective, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure gluPerspective(fovy, aspect, zNear, zFar: Single);'); + + Engine.RegExtMethod('glPushMatrix',{$IfDef FPC}@{$EndIf}_glPushMatrix, [], ''); + Engine.RegExtMethod('glPopMatrix',{$IfDef FPC}@{$EndIf}_glPopMatrix, [], ''); + Engine.RegExtMethod('glLoadIdentity',{$IfDef FPC}@{$EndIf}_glLoadIdentity, [], ''); + + Engine.RegExtMethod('glTranslatef',{$IfDef FPC}@{$EndIf}_glTranslatef, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glTranslatefv',{$IfDef FPC}@{$EndIf}_glTranslatefv, ['PVector3f'], ''); + Engine.RegExtMethod('glRotatef',{$IfDef FPC}@{$EndIf}_glRotatef, ['Single', 'Single', 'Single', 'Single'], '', + 'procedure glRotatef(angle, x, y, z: Single);'); + Engine.RegExtMethod('glRotate3f',{$IfDef FPC}@{$EndIf}_glRotatef, ['Single', 'Single', 'Single'], '', + 'procedure glRotate3f(x,y,z: Single);'); + Engine.RegExtMethod('glRotatefv',{$IfDef FPC}@{$EndIf}_glRotatefv, ['PVector3f'], ''); + Engine.RegExtMethod('glScalef',{$IfDef FPC}@{$EndIf}_glScalef, ['Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glScalefv',{$IfDef FPC}@{$EndIf}_glScalefv, ['PVector3f'], ''); + + //Engine.RegExtMethod('glMultMatrixf',{$IfDef FPC}@{$EndIf}_glMultMatrixf, ['TMatrix4f'], ''); + //Engine.RegExtMethod('glMatrixMode',{$IfDef FPC}@{$EndIf}_glMatrixMode, ['Integer'], ''); + //Engine.RegExtMethod('glOrtho',{$IfDef FPC}@{$EndIf}_glOrtho, ['Single','Single','Single','Single','Single','Single'], ''); + + //Engine.RegExtMethod('glPolygonMode',{$IfDef FPC}@{$EndIf}_glPolygonMode, ['Integer','Integer'], ''); + //Engine.RegExtMethod('glPolygonOffset',{$IfDef FPC}@{$EndIf}_glPolygonOffset, ['Single','Single'], ''); + Engine.RegExtMethod('glLineWidth',{$IfDef FPC}@{$EndIf}_glLineWidth, ['Integer'], ''); + Engine.RegExtMethod('glBlendFunc',{$IfDef FPC}@{$EndIf}_glBlendFunc, ['Integer', 'Integer'], ''); + Engine.RegExtMethod('glClearColor',{$IfDef FPC}@{$EndIf}_glClearColor, ['Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glAccum',{$IfDef FPC}@{$EndIf}_glAccum, ['Cardinal', 'Single'], ''); + Engine.RegExtMethod('glReadBuffer',{$IfDef FPC}@{$EndIf}_glReadBuffer, ['Cardinal'], ''); + + Engine.RegExtMethod('glLight4f',{$IfDef FPC}@{$EndIf}_glLight4f, ['Integer', 'Integer', 'Single', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glLight3f',{$IfDef FPC}@{$EndIf}_glLight3f, ['Integer', 'Integer', 'Single', 'Single', 'Single'], ''); + Engine.RegExtMethod('glLightf',{$IfDef FPC}@{$EndIf}_glLightf, ['Integer', 'Integer', 'Single'], ''); + + OutputDebugString(PChar('Rutis_EXT_OpenGl.RegisterEXTMethods - Successfully registered RUTIS OpenGL Support')); +End; + + + +End. + +{ +glGenLists +glDeleteLists +glCallList +glCallLists +glEndList +glListBase +glColorMaterial +glFrontFace +glPointSize +glDeleteTextures +glBindTexture +glDeleteTextures +glTexCoord2f +glTexCoord3f +glTexCoord4f +glTexGeni +glTexGenfv (4f) +glTexParameteri +glTexParameterf (4f) +glCopyTexImage2D +glCopyTexSubImage2D +glActiveTexture +glMultiTexCoord2f +glMultiTexCoord3f +glMultiTexCoord4f +glViewport + +gluLookAt + +glIsEnabled +glIsList +glIsTexture + + + + + +glBlendFuncSeparate +glBlendColor +glBlendEquation +glBlendEquationSeparate +glClearDepth +glClearStencil +glClipPlane +glColorMask +glDepthFunc +glDepthMask +glDepthRange +glFinish +glFlush +glFrustum + +glInitNames +glLoadName +glPushName +glPopName +glLightModelf (4f) +glLogicOp +glNewList +glRasterPos2f +glRasterPos3f +glWindowPos2f +glWindowPos3f +glRectf (x1,y1,x2,y2) +glRenderMode +glSelectBuffer +glShadeModel +glStencilFunc +glStencilFuncSeparate +glStencilMask +glStencilMaskSeparate +glStencilOp +glStencilOpSeparate +glTexImage2D +glTexSubImage2D +glTexImage3D +glTexSubImage3D +glFogCoordf +glGenQueries +glDeleteQueries +glIsQuery +glBeginQuery +glEndQuery +glGetQueryiv +glGetQueryObjectiv + +gluPickMatrix +gluLookAt +gluProject +gluUnProject +gluScaleImage +gluBuild2DMipmaps + + gluNewQuadric: TgluNewQuadric; + gluDeleteQuadric: TgluDeleteQuadric; + gluQuadricNormals: TgluQuadricNormals; + gluQuadricTexture: TgluQuadricTexture; + gluQuadricOrientation: TgluQuadricOrientation; + gluQuadricDrawStyle: TgluQuadricDrawStyle; + gluCylinder: TgluCylinder; + gluDisk: TgluDisk; + gluPartialDisk: TgluPartialDisk; + gluSphere: TgluSphere; + gluQuadricCallback: TgluQuadricCallback; + gluNewTess: TgluNewTess; + gluDeleteTess: TgluDeleteTess; + gluTessBeginPolygon: TgluTessBeginPolygon; + gluTessBeginContour: TgluTessBeginContour; + gluTessVertex: TgluTessVertex; + gluTessEndContour: TgluTessEndContour; + gluTessEndPolygon: TgluTessEndPolygon; + gluTessProperty: TgluTessProperty; + gluTessNormal: TgluTessNormal; + gluTessCallback: TgluTessCallback; + gluGetTessProperty: TgluGetTessProperty; + gluNewNurbsRenderer: TgluNewNurbsRenderer; + gluDeleteNurbsRenderer: TgluDeleteNurbsRenderer; + gluBeginSurface: TgluBeginSurface; + gluBeginCurve: TgluBeginCurve; + gluEndCurve: TgluEndCurve; + gluEndSurface: TgluEndSurface; + gluBeginTrim: TgluBeginTrim; + gluEndTrim: TgluEndTrim; + gluPwlCurve: TgluPwlCurve; + gluNurbsCurve: TgluNurbsCurve; + gluNurbsSurface: TgluNurbsSurface; + gluLoadSamplingMatrices: TgluLoadSamplingMatrices; + gluNurbsProperty: TgluNurbsProperty; + gluGetNurbsProperty: TgluGetNurbsProperty; + gluNurbsCallback: TgluNurbsCallback; + gluBeginPolygon: TgluBeginPolygon; + gluNextContour: TgluNextContour; + gluEndPolygon: TgluEndPolygon; + + glGetBooleanv: TglGetBooleanv; + glGetClipPlane: TglGetClipPlane; + glGetDoublev: TglGetDoublev; + glGetError: TglGetError; + glGetFloatv: TglGetFloatv; + glGetIntegerv: TglGetIntegerv; + glGetLightfv: TglGetLightfv; + glGetLightiv: TglGetLightiv; + glGetMapdv: TglGetMapdv; + glGetMapfv: TglGetMapfv; + glGetMapiv: TglGetMapiv; + glGetMaterialfv: TglGetMaterialfv; + glGetMaterialiv: TglGetMaterialiv; + glGetPixelMapfv: TglGetPixelMapfv; + glGetPixelMapuiv: TglGetPixelMapuiv; + glGetPixelMapusv: TglGetPixelMapusv; + glGetPointerv: TglGetPointerv; + glGetPolygonStipple: TglGetPolygonStipple; + glGetTexEnvfv: TglGetTexEnvfv; + glGetTexEnviv: TglGetTexEnviv; + glGetTexGendv: TglGetTexGendv; + glGetTexGenfv: TglGetTexGenfv; + glGetTexGeniv: TglGetTexGeniv; + glGetTexImage: TglGetTexImage; + glGetTexLevelParameterfv: TglGetTexLevelParameterfv; + glGetTexLevelParameteriv: TglGetTexLevelParameteriv; + glGetTexParameterfv: TglGetTexParameterfv; + glGetTexParameteriv: TglGetTexParameteriv; + +} diff --git a/Units/RUTIS/Rutis_ExtMethodInfoWin.dfm b/Units/RUTIS/Rutis_ExtMethodInfoWin.dfm new file mode 100644 index 0000000..2531696 --- /dev/null +++ b/Units/RUTIS/Rutis_ExtMethodInfoWin.dfm @@ -0,0 +1,85 @@ +object FExtMethodListInfo: TFExtMethodListInfo + Left = 0 + Top = 0 + BorderIcons = [biSystemMenu, biMaximize] + Caption = 'EXT Methods Info' + ClientHeight = 305 + ClientWidth = 526 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + FormStyle = fsStayOnTop + OldCreateOrder = False + Position = poScreenCenter + OnCreate = FormCreate + OnHide = FormHide + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 + object ExtList: TListBox + Left = 0 + Top = 25 + Width = 526 + Height = 280 + Align = alClient + Font.Charset = ANSI_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Courier New' + Font.Style = [] + ItemHeight = 14 + ParentFont = False + ParentShowHint = False + ShowHint = True + TabOrder = 1 + OnDblClick = ExtListDblClick + OnMouseMove = ExtListMouseMove + end + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 526 + Height = 25 + Align = alTop + BevelOuter = bvNone + TabOrder = 0 + object BtnSortDefault: TButton + Left = 0 + Top = 1 + Width = 80 + Height = 25 + Caption = 'Default' + TabOrder = 1 + OnClick = BtnSortDefaultClick + end + object BtnSortAlphabetical: TButton + Left = 80 + Top = 1 + Width = 80 + Height = 25 + Caption = 'Alphabetical' + TabOrder = 2 + OnClick = BtnSortAlphabeticalClick + end + object EdSearch: TEdit + Left = 165 + Top = 3 + Width = 357 + Height = 21 + TabOrder = 0 + OnChange = EdSearchChange + OnMouseDown = EdSearchMouseDown + end + end + object PopupMenu1: TPopupMenu + Left = 208 + Top = 120 + object Insertintocode1: TMenuItem + Caption = 'Insert into code' + OnClick = Insertintocode1Click + end + end +end diff --git a/Units/RUTIS/Rutis_ExtMethodInfoWin.lfm b/Units/RUTIS/Rutis_ExtMethodInfoWin.lfm new file mode 100644 index 0000000..8f9ea80 --- /dev/null +++ b/Units/RUTIS/Rutis_ExtMethodInfoWin.lfm @@ -0,0 +1,28 @@ +object FExtMethodListInfo: TFExtMethodListInfo + Left = 76 + Height = 305 + Top = 99 + Width = 526 + BorderIcons = [biSystemMenu, biMaximize] + Caption = 'EXT Methods Info' + ClientHeight = 305 + ClientWidth = 526 + Font.Height = -11 + Font.Name = 'Tahoma' + FormStyle = fsStayOnTop + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object ExtList: TListBox + Left = 0 + Height = 305 + Top = 0 + Width = 526 + Align = alClient + Font.CharSet = ANSI_CHARSET + Font.Height = -13 + Font.Name = 'Courier New' + ItemHeight = 0 + ParentFont = False + TabOrder = 0 + end +end diff --git a/Units/RUTIS/Rutis_ExtMethodInfoWin.lrs b/Units/RUTIS/Rutis_ExtMethodInfoWin.lrs new file mode 100644 index 0000000..5823e51 --- /dev/null +++ b/Units/RUTIS/Rutis_ExtMethodInfoWin.lrs @@ -0,0 +1,13 @@ +{ Das ist eine automatisch erzeugte Lazarus-Ressourcendatei } + +LazarusResources.Add('TFExtMethodListInfo','FORMDATA',[ + 'TPF0'#19'TFExtMethodListInfo'#18'FExtMethodListInfo'#4'Left'#2'L'#6'Height'#3 + +'1'#1#3'Top'#2'c'#5'Width'#3#14#2#11'BorderIcons'#11#12'biSystemMenu'#10'biM' + +'aximize'#0#7'Caption'#6#16'EXT Methods Info'#12'ClientHeight'#3'1'#1#11'Cli' + +'entWidth'#3#14#2#11'Font.Height'#2#245#9'Font.Name'#6#6'Tahoma'#9'FormStyle' + +#7#11'fsStayOnTop'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.2' + +'8.2'#0#8'TListBox'#7'ExtList'#4'Left'#2#0#6'Height'#3'1'#1#3'Top'#2#0#5'Wid' + +'th'#3#14#2#5'Align'#7#8'alClient'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Fo' + +'nt.Height'#2#243#9'Font.Name'#6#11'Courier New'#10'ItemHeight'#2#0#10'Paren' + +'tFont'#8#8'TabOrder'#2#0#0#0#0 +]); diff --git a/Units/RUTIS/Rutis_ExtMethodInfoWin.pas b/Units/RUTIS/Rutis_ExtMethodInfoWin.pas new file mode 100644 index 0000000..51eea37 --- /dev/null +++ b/Units/RUTIS/Rutis_ExtMethodInfoWin.pas @@ -0,0 +1,223 @@ +Unit Rutis_ExtMethodInfoWin; + +Interface + +Uses + SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, Menus, Math + {$IFDEF FPC},LResources{$ENDIF}; + +Type + TExtMethodInfo = Record + Name : String; + Category : String; + Description : String; + IsFunction : Boolean; + ExtMethodType : Pointer; + End; + + TFExtMethodListInfo = Class(TForm) + ExtList : TListBox; + Panel1 : TPanel; + BtnSortDefault : TButton; + BtnSortAlphabetical : TButton; + EdSearch : TEdit; + PopupMenu1 : TPopupMenu; + Insertintocode1 : TMenuItem; + Procedure ExtListDblClick(Sender : TObject); + Procedure FormCreate(Sender : TObject); + Procedure ExtListMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer); + Procedure FormHide(Sender : TObject); + Procedure FormShow(Sender : TObject); + Procedure BtnSortDefaultClick(Sender : TObject); + Procedure BtnSortAlphabeticalClick(Sender : TObject); + Procedure EdSearchChange(Sender : TObject); + Procedure EdSearchMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + Procedure Insertintocode1Click(Sender : TObject); + Private + LastHoveredRow : Integer; + Procedure ShowList; + { Private-Deklarationen } + Public + ResultIndex : Integer; + ResultExtMethod : Pointer; + //Hints : TStringList; + Sorted : Array Of Integer; + ExtMethods : Array Of TExtMethodInfo; + { Public-Deklarationen } + End; + +Implementation + +{$IFNDEF FPC} + {$R *.dfm} + +{$ENDIF} + +Function IsStr1LowerStr2(s1, s2 : String) : Boolean; +Var + i : Integer; +Begin + i := 1; + s1 := LowerCase(s1) + #255; + s2 := LowerCase(s2) + #254; + While s1[i] = s2[i] Do + Inc(i); + Result := s1[i] < s2[i]; +End; + +Procedure TFExtMethodListInfo.ShowList; +Var + i : Integer; + s : String; +Begin + ExtList.Clear; + For i := 0 To high(ExtMethods) Do + Begin + If Sorted[i] < 0 Then Continue; + s := ExtMethods[Sorted[i] - 1].Name; + // If ExtMethods[Sorted[i]].IsFunction then + // s := 'Function ' + ExtMethods[Sorted[i]].Name + // else + // s := 'Procedure ' + ExtMethods[Sorted[i]].Name; + // If ExtMethods[Sorted[i]].IsFunction then + // s := 'F ' + ExtMethods[Sorted[i]].Name + // else + // s := 'P ' + ExtMethods[Sorted[i]].Name; + ExtList.Items.Add(s); + End; + + Canvas.Font := ExtList.Font; + {$ifndef FPC} + ExtList.ScrollWidth := 0; + For i := 0 To ExtList.Items.Count - 1 Do + ExtList.ScrollWidth := Max(ExtList.ScrollWidth, Canvas.TextWidth(ExtList.Items[i])); + {$endif} +End; + +Procedure TFExtMethodListInfo.BtnSortAlphabeticalClick(Sender : TObject); +Var + i, j : Integer; + completed : Boolean; +Begin + SetLength(Sorted, length(ExtMethods)); + For i := 0 To high(ExtMethods) Do + Sorted[i] := i + 1; + + Repeat + completed := True; + For i := 0 To high(ExtMethods) - 1 Do + If not IsStr1LowerStr2(ExtMethods[Sorted[i] - 1].Name, ExtMethods[Sorted[i + 1] - 1].Name) Then + Begin + j := Sorted[i]; + Sorted[i] := Sorted[i + 1]; + Sorted[i + 1] := j; + completed := False; + End; + Until completed; + + ShowList; +End; + +Procedure TFExtMethodListInfo.BtnSortDefaultClick(Sender : TObject); +Var + i : Integer; +Begin + SetLength(Sorted, length(ExtMethods)); + For i := 0 To high(ExtMethods) Do + Sorted[i] := i + 1; + + ShowList; +End; + +Procedure TFExtMethodListInfo.EdSearchChange(Sender : TObject); +Var + i : Integer; +Begin + For i := 0 To high(ExtMethods) Do + Begin + Sorted[i] := abs(Sorted[i]); + If length(EdSearch.Text) > 0 Then + If Pos(LowerCase(EdSearch.Text), LowerCase(ExtMethods[Sorted[i] - 1].Name)) = 0 Then + Sorted[i] := -Sorted[i]; + End; + ShowList; +End; + +Procedure TFExtMethodListInfo.EdSearchMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +Begin +// EdSearch.SelStart := 0; +// EdSearch.SelLength := Length(EdSearch.Text); +End; + +Procedure TFExtMethodListInfo.ExtListDblClick(Sender : TObject); +Begin + Insertintocode1Click(nil); +End; + +Procedure TFExtMethodListInfo.ExtListMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer); +Var + HoveredRow : Integer; + I : Integer; +Begin + HoveredRow := ExtList.ItemAtPos(Point(X, Y), True); + If (HoveredRow > -1) and + (HoveredRow < length(ExtMethods)) and + (HoveredRow <> LastHoveredRow) Then + Begin + LastHoveredRow := HoveredRow; + i := -1; + Repeat + Inc(i); + If Sorted[I] > 0 Then + Dec(HoveredRow); + Until HoveredRow < 0; + ExtList.Hint := ExtMethods[abs(Sorted[i]) - 1].Description; + Application.Hint := ExtList.Hint; + Application.HintPause := 0; + Application.HintHidePause := 60000; + {$ifndef FPC} + Application.ActivateHint(Point(X, Y)); + {$endif} + End; +End; + +Procedure TFExtMethodListInfo.FormCreate(Sender : TObject); +Begin + ResultIndex := -1; + LastHoveredRow := -1; + ResultExtMethod := nil; +End; + +Procedure TFExtMethodListInfo.FormHide(Sender : TObject); +Begin + Application.HintPause := 2500; +End; + +Procedure TFExtMethodListInfo.FormShow(Sender : TObject); +Begin + BtnSortDefault.Click; +End; + +Procedure TFExtMethodListInfo.Insertintocode1Click(Sender : TObject); +Var i, item : Integer; +Begin + item := ExtList.ItemIndex; + i := -1; + Repeat + Inc(i); + If Sorted[I] > 0 Then + Dec(item); + Until item < 0; + + ResultIndex := abs(Sorted[i]) - 1; + ResultExtMethod := ExtMethods[ResultIndex].ExtMethodType; + Close; +End; + +Initialization + {$IFDEF FPC} + {$I Rutis_ExtMethodInfoWin.lrs} + {$ENDIF} +End. + diff --git a/Units/RUTIS/Rutis_INI_Settings.pas b/Units/RUTIS/Rutis_INI_Settings.pas new file mode 100644 index 0000000..5fe7bc2 --- /dev/null +++ b/Units/RUTIS/Rutis_INI_Settings.pas @@ -0,0 +1,93 @@ +Unit Rutis_INI_Settings; + +Interface + +Uses + SysUtils, IniFiles, registry, Rutis_Engine; + +Var + Rutis_INI : TCustomIniFile; + +Procedure RINISettings_Open(AppPath, ScriptPath : String); +Function RINISettings_OpenReg : Boolean; +Procedure RINISettings_OpenIni(FileName : String); +Procedure RINISettings_ApplyMainSettings(Engine : TRutisEngine); + +Implementation + +Procedure RINISettings_Open(AppPath, ScriptPath : String); +Begin + If FileExists(ScriptPath + '\RutisSettings.ini') Then + Begin + RINISettings_OpenIni(ScriptPath + '\RutisSettings.ini'); + exit; + End; + + If RINISettings_OpenReg Then exit; + + SetCurrentDir(AppPath); + If FileExists('.\Rutis_Settings.ini') Then + Begin + RINISettings_OpenIni('.\Rutis_Settings.ini'); + exit; + End; + + If FileExists('..\Rutis_Settings.ini') Then + Begin + RINISettings_OpenIni('..\Rutis_Settings.ini'); + exit; + End; + + RINISettings_OpenReg; +End; + +Function RINISettings_OpenReg : Boolean; +Begin + Rutis_INI.Free; + Rutis_INI := TRegistryIniFile.Create('Software\RUTIS'); + Result := Rutis_INI.SectionExists(''); +End; + +Procedure RINISettings_OpenIni(FileName : String); +Begin + Rutis_INI.Free; + Rutis_INI := TIniFile.Create(FileName); +End; + +Procedure RINISettings_ApplyMainSettings(Engine : TRutisEngine); +Var + i : Integer; + Str : String; +Begin + If Rutis_INI = nil Then + Rutis_INI := TRegistryIniFile.Create('Software\RUTIS'); + + //Libary Paths + SetLength(Engine.UnitFileManager.Paths, 0); + i := 0; + While True Do + Begin + Str := Rutis_INI.ReadString('Compiler\Libary', 'Path' + IntToStr(i), ''); + If Str = '' Then break; + Engine.UnitFileManager.AddPath(Str); + Inc(i); + End; + + //Compiler Settings + Engine.Compiler.optArrangeFields := Rutis_INI.ReadBool('Compiler', 'ArrangeRecordFields', True); + Engine.Compiler.optArrangeSize := Rutis_INI.ReadInteger('Compiler', 'RecordArrangeSize', 8); + + Engine.OptProcessTimerCount := Rutis_INI.ReadInteger('VM', 'ProcessTickCount', 100000); + + //SAVE SETTINGS + Rutis_INI.WriteBool('Compiler', 'ArrangeRecordFields', Engine.Compiler.optArrangeFields); + Rutis_INI.WriteInteger('Compiler', 'RecordArrangeSize', Engine.Compiler.optArrangeSize); + + Rutis_INI.WriteInteger('VM', 'ProcessTickCount', Engine.OptProcessTimerCount); +End; + +Initialization +Finalization + Rutis_INI.Free; +End. + diff --git a/Units/RUTIS/Rutis_Stack.pas b/Units/RUTIS/Rutis_Stack.pas new file mode 100644 index 0000000..61c3f53 --- /dev/null +++ b/Units/RUTIS/Rutis_Stack.pas @@ -0,0 +1,1131 @@ +{/============================================================================== +//============================================================================== + +RUTIS-Engine (RunTimeScript-Engine) + +Rutis_Defs.pas (part of) RUTIS-Engine + +--> This unit contains the types, defines, functions, etc. + which are used by the RUTIS-Engine + +//============================================================================== + +Author : Björn Zeutzheim +E-Mail : bjoern@zeutzheim-boppard.de + +//============================================================================== + +License: Dieses Projekt (RUTIS-Engine) steht unter einer / + This project is licensed under the + Creative Commons 3.0 BY-NC-SA (German) License + +Diese Lizens beinhaltet / This license includes: +-> Namensnennung / Attribution +-> Keine kommerzielle Nutzung / Noncommercial +-> Weitergabe unter gleichen Bedingungen / Share Alike + +Ein ausformulierter Lizensvertrag ist über folgende Adresse erreichbar: +The Legal Code (the full license) can be read at the following adress: +> http: //creativecommons.org/licenses/by-nc-sa/3.0/de/ + +//============================================================================== +//==============================================================================} + +Unit Rutis_Stack; + +Interface + +{$i Delphi_Versions.inc} + +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +Uses + SysUtils; + + //==================================================================== + //==================================================================== + +Type + {$ifndef DELPHI_7_UP} + PInteger = ^Integer; + TVarType = Word; + {$endif} + + PPAnsiString = ^PAnsiString; + RutisString = Pointer; + PRutisString = ^RutisString; + + {$IFDEF FPC} + PBoolean = ^Boolean; + {$ENDIF} + +//==================================================================== +Type + TRutisStackBlock = Record + Top : Integer; + Data : PByte; + End; + + TRutisStackFreeInfo = Record + Adr : Integer; + IsStr : Boolean; + End; + + TRutisBasicStack = Class + Private + fStackBlockSize : Integer; + Function GetData(Index : Integer) : Pointer; + Public + Blocks : Array Of TRutisStackBlock; + TopBlock : Integer; + Top : Integer; + DecTop : Integer; + FreeInfo : Array Of TRutisStackFreeInfo; + Property Data[Index : Integer] : Pointer Read GetData; + + Procedure Copy(Src, Dst, Size : Integer); + Function Push(Size : Integer; SetZero : Boolean = False) : Integer; + Procedure Pop(Size : Integer); + Procedure PopTo(Size : Integer); + + {$REGION 'Get-Var-Pointer functions'} + Function GetByte(Const adr : Integer) : PByte; Inline; + Function GetWord(Const adr : Integer) : PWord; Inline; + Function GetCardinal(Const adr : Integer) : PCardinal; Inline; + Function GetShortInt(Const adr : Integer) : PShortInt; Inline; + Function GetSmallInt(Const adr : Integer) : PSmallInt; Inline; + Function GetInteger(Const adr : Integer) : PInteger; Inline; + Function GetInt64(Const adr : Integer) : PInt64; Inline; + Function GetSingle(Const adr : Integer) : PSingle; Inline; + Function GetDouble(Const adr : Integer) : PDouble; Inline; + Function GetExtended(Const adr : Integer) : PExtended; Inline; + Function GetAChar(Const adr : Integer) : PAnsiChar; Inline; + Function GetWChar(Const adr : Integer) : PWideChar; Inline; + Function GetString(Const adr : Integer) : PRutisString; Inline; + Function GetShortString(Const adr : Integer) : PShortString; Inline; + {$ENDREGION} + + {$REGION 'Read functions'} + Function ReadByte(Const adr : Integer) : Byte; Inline; + Function ReadWord(Const adr : Integer) : Word; Inline; + Function ReadCardinal(Const adr : Integer) : Cardinal; Inline; + Function ReadShortInt(Const adr : Integer) : Shortint; Inline; + Function ReadSmallInt(Const adr : Integer) : Smallint; Inline; + Function ReadInteger(Const adr : Integer) : Integer; Inline; + Function ReadInt64(Const adr : Integer) : Int64; Inline; + Function ReadSingle(Const adr : Integer) : Single; Inline; + Function ReadDouble(Const adr : Integer) : Double; Inline; + Function ReadExtended(Const adr : Integer) : Extended; Inline; + Function ReadAChar(Const adr : Integer) : AnsiChar; Inline; + Function ReadWChar(Const adr : Integer) : Widechar; Inline; + Function ReadString(Const adr : Integer) : RutisString; Inline; + Function ReadShortString(Const adr : Integer) : ShortString; Inline; + {$ENDREGION} + + {$REGION 'Write functions'} + Procedure WriteByte(Const adr : Integer; Const Val : Byte); Inline; + Procedure WriteWord(Const adr : Integer; Const Val : Word); Inline; + Procedure WriteCardinal(Const adr : Integer; Const Val : Cardinal); Inline; + Procedure WriteShortInt(Const adr : Integer; Const Val : Shortint); Inline; + Procedure WriteSmallInt(Const adr : Integer; Const Val : Smallint); Inline; + Procedure WriteInteger(Const adr : Integer; Const Val : Integer); Inline; + Procedure WriteInt64(Const adr : Integer; Const Val : Int64); Inline; + Procedure WriteSingle(Const adr : Integer; Const Val : Single); Inline; + Procedure WriteDouble(Const adr : Integer; Const Val : Double); Inline; + Procedure WriteExtended(Const adr : Integer; Const Val : Extended); Inline; + Procedure WriteAChar(Const adr : Integer; Const Val : AnsiChar); Inline; + Procedure WriteWChar(Const adr : Integer; Const Val : Widechar); Inline; + Procedure WriteString(Const adr : Integer; Const Val : RutisString); Inline; + Procedure WriteShortString(Const adr : Integer; Const Val : ShortString); Inline; + {$ENDREGION} + + {$REGION 'Push functions'} + Procedure PushByte(Const Val : Byte); + Procedure PushWord(Const Val : Word); + Procedure PushCardinal(Const Val : Cardinal); + Procedure PushShortInt(Const Val : Shortint); + Procedure PushSmallInt(Const Val : Smallint); + Procedure PushInteger(Const Val : Integer); + Procedure PushInt64(Const Val : Int64); + Procedure PushSingle(Const Val : Single); + Procedure PushDouble(Const Val : Double); + Procedure PushExtended(Const Val : Extended); + Procedure PushAChar(Const Val : AnsiChar); + Procedure PushWChar(Const Val : Widechar); + Procedure PushString(Const Val : RutisString; Const AutoFree : Boolean); + Procedure PushAStringData(Const Val : Ansistring); + Procedure PushShortString(Const Val : ShortString); + {$ENDREGION} + + {$REGION 'Pop functions'} + Function PopByte : Byte; + Function PopWord : Word; + Function PopCardinal : Cardinal; + Function PopShortInt : Shortint; + Function PopSmallInt : Smallint; + Function PopInteger : Integer; + Function PopInt64 : Int64; + Function PopSingle : Single; + Function PopDouble : Double; + Function PopExtended : Extended; + Function PopAChar : AnsiChar; + Function PopWChar : Widechar; + Function PopString : RutisString; + Function PopShortString : ShortString; + {$ENDREGION} + + Procedure AddFreeData(Adr : Integer; IsStr : Boolean); + Procedure Update_FreeData; + Function PointerInBlockData(p : Pointer) : Boolean; + + Procedure Clear; + Constructor Create(AStackBlockSize : Cardinal); + Destructor Destroy; Override; + Property StackBlockSize : Integer Read fStackBlockSize; + End; + + +//==================================================================== +Procedure CopyStackData(Src, Dst : PByte; Size : Integer); + +//==================================================================== +{$REGION 'Pointer-variable access functions'} +//Pointer-variable access functions for compability with Windows-CE +//==================================================================== +Function GetPByte(Const Adr : PByte) : Byte; Inline; +Function GetPWord(Const Adr : PWord) : Word; Inline; +Function GetPCardinal(Const Adr : PCardinal) : Cardinal; Inline; +Function GetPShortInt(Const Adr : PShortInt) : ShortInt; Inline; +Function GetPSmallInt(Const Adr : PSmallInt) : Smallint; Inline; +Function GetPInteger(Const Adr : PInteger) : Integer; Inline; +Function GetPInt64(Const Adr : PInt64) : Int64; Inline; +Function GetPSingle(Const Adr : PSingle) : Single; Inline; +Function GetPDouble(Const Adr : PDouble) : Double; Inline; +Function GetPExtended(Const Adr : PExtended) : Extended; Inline; +Function GetPAnsiChar(Const Adr : PAnsiChar) : AnsiChar; Inline; +Function GetPWideChar(Const Adr : PWideChar) : Widechar; Inline; +Function GetPAnsiString(Const Adr : PAnsiString) : AnsiString; Inline; +Function GetPWideString(Const Adr : PWideString) : WideString; Inline; +Function GetPShortString(Const Adr : PShortString) : ShortString; Inline; +Function GetPPointer(Const Adr : PPointer) : Pointer; Inline; +//==================================================================== +Procedure SetPByte(Const Adr : PByte; Const Val : Byte); Inline; +Procedure SetPWord(Const Adr : PWord; Const Val : Word); Inline; +Procedure SetPCardinal(Const Adr : PCardinal; Const Val : Cardinal); Inline; +Procedure SetPShortInt(Const Adr : PShortInt; Const Val : ShortInt); Inline; +Procedure SetPSmallInt(Const Adr : PSmallInt; Const Val : Smallint); Inline; +Procedure SetPInteger(Const Adr : PInteger; Const Val : Integer); Inline; +Procedure SetPInt64(Const Adr : PInt64; Const Val : Int64); Inline; +Procedure SetPSingle(Const Adr : PSingle; Const Val : Single); Inline; +Procedure SetPDouble(Const Adr : PDouble; Const Val : Double); Inline; +Procedure SetPExtended(Const Adr : PExtended; Const Val : Extended); Inline; +Procedure SetPAnsiChar(Const Adr : PAnsiChar; Const Val : AnsiChar); Inline; +Procedure SetPWideChar(Const Adr : PWideChar; Const Val : Widechar); Inline; +Procedure SetPAnsiString(Const Adr : PPointer; Const Val : AnsiString); Inline; +Procedure SetPWideString(Const Adr : PPointer; Const Val : WideString); Inline; +Procedure SetPShortString(Const Adr : PShortString; Const Val : ShortString); Inline; +Procedure SetPPointer(Const Adr : PPointer; Const Val : Pointer); Inline; +//==================================================================== +{$ENDREGION} + +Implementation + +//============================================================================== +{$REGION 'Pointer-variable access functions'} +//Pointer-variable access functions for compability with Windows-CE +//Each one is defined as inline so it does not waste any performance when not +//compiling for Windows-CE +//============================================================================== + +Function GetPByte(Const Adr : PByte) : Byte; +Begin + Result := Adr^; +End; + +Function GetPWord(Const Adr : PWord) : Word; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPCardinal(Const Adr : PCardinal) : Cardinal; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPShortInt(Const Adr : PShortInt) : ShortInt; +Begin + Result := Adr^; +End; + +Function GetPSmallInt(Const Adr : PSmallInt) : Smallint; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPInteger(Const Adr : PInteger) : Integer; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPInt64(Const Adr : PInt64) : Int64; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPSingle(Const Adr : PSingle) : Single; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPDouble(Const Adr : PDouble) : Double; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPExtended(Const Adr : PExtended) : Extended; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPAnsiChar(Const Adr : PAnsiChar) : AnsiChar; +Begin + Result := Adr^; +End; + +Function GetPWideChar(Const Adr : PWideChar) : Widechar; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPAnsiString(Const Adr : PAnsiString) : AnsiString; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPWideString(Const Adr : PWideString) : WideString; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPShortString(Const Adr : PShortString) : ShortString; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +Function GetPPointer(Const Adr : PPointer) : Pointer; +Begin + {$ifdef WinCE} + Result := unaligned(Adr^); + {$else WinCE} + Result := Adr^; + {$endif} +End; + +//============================================================================== + +Procedure SetPByte(Const Adr : PByte; Const Val : Byte); +Begin + Adr^ := Val; +End; + +Procedure SetPWord(Const Adr : PWord; Const Val : Word); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPCardinal(Const Adr : PCardinal; Const Val : Cardinal); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPShortInt(Const Adr : PShortInt; Const Val : ShortInt); +Begin + Adr^ := Val; +End; + +Procedure SetPSmallInt(Const Adr : PSmallInt; Const Val : Smallint); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPInteger(Const Adr : PInteger; Const Val : Integer); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPInt64(Const Adr : PInt64; Const Val : Int64); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPSingle(Const Adr : PSingle; Const Val : Single); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPDouble(Const Adr : PDouble; Const Val : Double); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPExtended(Const Adr : PExtended; Const Val : Extended); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPAnsiChar(Const Adr : PAnsiChar; Const Val : AnsiChar); +Begin + Adr^ := Val; +End; + +Procedure SetPWideChar(Const Adr : PWideChar; Const Val : Widechar); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPAnsiString(Const Adr : PPointer; Const Val : AnsiString); +var StrCopy : Pointer; +Begin + StrCopy := nil; + AnsiString(StrCopy) := Val; + {$ifdef WinCE} + unaligned(Adr^) := StrCopy; + {$else WinCE} + Adr^ := StrCopy; + {$endif} +End; + +Procedure SetPWideString(Const Adr : PPointer; Const Val : WideString); +var StrCopy : Pointer; +Begin + StrCopy := nil; + WideString(StrCopy) := Val; + {$ifdef WinCE} + unaligned(Adr^) := StrCopy; + {$else WinCE} + Adr^ := StrCopy; + {$endif} +End; + +Procedure SetPShortString(Const Adr : PShortString; Const Val : ShortString); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +Procedure SetPPointer(Const Adr : PPointer; Const Val : Pointer); +Begin + {$ifdef WinCE} + unaligned(Adr^) := Val; + {$else WinCE} + Adr^ := Val; + {$endif} +End; + +{$ENDREGION} + +//==================================================================== +Procedure CopyStackData(Src, Dst : PByte; Size : Integer); +Begin + move(Src^, Dst^, Size); +End; + +{Procedure CopyStackData(Src, Dst : PByte; Size : Integer); +Begin + Case Size Of + 1 : dst^ := src^; + 2 : PWord(dst)^ := PWord(src)^; + 4 : PCardinal(dst)^ := PCardinal(src)^; + 8 : PInt64(dst)^ := PInt64(src)^; + Else + While Size > 0 Do + Begin + If Size >= 8 Then + Begin + PInt64(dst)^ := PInt64(src)^; + Inc(dst, 8); + Inc(src, 8); + Size := Size - 8; + Continue; + End; + If Size >= 4 Then + Begin + PCardinal(dst)^ := PCardinal(src)^; + Inc(dst, 4); + Inc(src, 4); + Size := Size - 4; + Continue; + End; + If Size >= 2 Then + Begin + PWord(dst)^ := PWord(src)^; + Inc(dst, 2); + Inc(src, 2); + Size := Size - 2; + Continue; + End; + dst^ := src^; + Size := Size - 1; + End; + End; +End; //} +//============================================================================== + { TRutisStack } + +Constructor TRutisBasicStack.Create(AStackBlockSize : Cardinal); +Begin + fStackBlockSize := AStackBlockSize; + + SetLength(Blocks, 1); + TopBlock := 0; + Blocks[0].Data := AllocMem(fStackBlockSize); +End; + +Destructor TRutisBasicStack.Destroy; +Begin + Clear; + FreeMem(Blocks[0].Data); + Inherited; +End; + +Procedure TRutisBasicStack.Clear; +Var i : Integer; +Begin + Try + Top := 0; + Update_FreeData; + For i := 1 To high(Blocks) Do + FreeMem(Blocks[i].Data); + Finally + DecTop := 0; + SetLength(Blocks, 1); + TopBlock := 0; + //FillChar(Blocks[0].Data^, fStackBlockSize, 0); + End; +End; + +//============================================================================== + +Function TRutisBasicStack.GetData(Index : Integer) : Pointer; +Var i : Integer; +Begin + i := TopBlock; + Index := Index - DecTop; + While (Index < 0) and (i > 0) Do + Begin + Index := Index + Blocks[i - 1].Top; + Dec(i); + End; + Result := Blocks[i].Data; + inc(Cardinal(Result), Index); +End; + +//============================================================================== + +Procedure TRutisBasicStack.Copy(Src, Dst, Size : Integer); +Begin + CopyStackData(Data[Src], Data[Dst], Size); +End; + +Function TRutisBasicStack.Push(Size : Integer; SetZero : Boolean) : Integer; +Var + Ptr : PByte; +Begin + Update_FreeData; + Result := Top; + If Top - DecTop + Size > fStackBlockSize - 1 Then + Begin + Blocks[TopBlock].Top := Top - DecTop; + DecTop := DecTop + Blocks[TopBlock].Top; + Inc(TopBlock); + If TopBlock > high(Blocks) Then + Begin + SetLength(Blocks, length(Blocks) + 1); + Blocks[TopBlock].Data := AllocMem(fStackBlockSize); + //FillChar(Blocks[TopBlock].Data^, fStackBlockSize, 0); + End; + End; + Top := Top + Size; + If SetZero Then + Begin + Ptr := Data[Result]; + FillChar(Ptr^, Size, 0); + End; +End; + +Procedure TRutisBasicStack.Pop(Size : Integer); +Var int : Integer; +Begin + Update_FreeData; + Top := Top - Size; + If Top < 0 Then Top := 0; + While Top - DecTop < -fStackBlockSize Do + Begin + If DecTop = 0 Then + Begin + Top := 0; + exit; + End; + int := TopBlock; + DecTop := DecTop - Blocks[int - 1].Top; + Dec(TopBlock); + //SetLength(Blocks, int); + End; +End; + +Procedure TRutisBasicStack.PopTo(Size : Integer); +Begin + If Size < Top Then + Pop(Top - Size); +End; + +//============================================================================== +{$REGION 'Get-Var-Pointer functions'} + +Function TRutisBasicStack.GetByte(Const adr : Integer) : PByte; +Begin + Result := PByte(Data[Adr]); +End; + +Function TRutisBasicStack.GetWord(Const adr : Integer) : PWord; +Begin + Result := PWord(Data[Adr]); +End; + +Function TRutisBasicStack.GetCardinal(Const adr : Integer) : PCardinal; +Begin + Result := PCardinal(Data[Adr]); +End; + +Function TRutisBasicStack.GetShortInt(Const adr : Integer) : PShortInt; +Begin + Result := PShortInt(Data[Adr]); +End; + +Function TRutisBasicStack.GetSmallInt(Const adr : Integer) : PSmallInt; +Begin + Result := PSmallInt(Data[Adr]); +End; + +Function TRutisBasicStack.GetInteger(Const adr : Integer) : PInteger; +Begin + Result := PInteger(Data[Adr]); +End; + +Function TRutisBasicStack.GetInt64(Const adr : Integer) : PInt64; +Begin + Result := PInt64(Data[Adr]); +End; + +Function TRutisBasicStack.GetSingle(Const adr : Integer) : PSingle; +Begin + Result := PSingle(Data[Adr]); +End; + +Function TRutisBasicStack.GetDouble(Const adr : Integer) : PDouble; +Begin + Result := PDouble(Data[Adr]); +End; + +Function TRutisBasicStack.GetExtended(Const adr : Integer) : PExtended; +Begin + Result := PExtended(Data[Adr]); +End; + +Function TRutisBasicStack.GetAChar(Const adr : Integer) : PAnsiChar; +Begin + Result := PAnsiChar(Data[Adr]); +End; + +Function TRutisBasicStack.GetWChar(Const adr : Integer) : PWideChar; +Begin + Result := PWideChar(Data[Adr]); +End; + +Function TRutisBasicStack.GetString(Const adr : Integer) : PRutisString; +Begin + Result := PRutisString(Data[Adr]); +End; + +Function TRutisBasicStack.GetShortString(Const adr : Integer) : PShortString; +Begin + Result := PShortString(Data[Adr]); +End; + +{$ENDREGION} + +//============================================================================== +{$REGION 'Read functions'} + +Function TRutisBasicStack.ReadByte(Const adr : Integer) : Byte; +Begin + Result := PByte(Data[Adr])^; +End; + +Function TRutisBasicStack.ReadWord(Const adr : Integer) : Word; +Begin + Result := GetPWord(Data[Adr]); +End; + +Function TRutisBasicStack.ReadCardinal(Const adr : Integer) : Cardinal; +Begin + Result := GetPCardinal(Data[Adr]); +End; + +Function TRutisBasicStack.ReadShortInt(Const adr : Integer) : Shortint; +Begin + Result := PShortInt(Data[Adr])^; +End; + +Function TRutisBasicStack.ReadSmallInt(Const adr : Integer) : Smallint; +Begin + Result := GetPSmallInt(Data[Adr]); +End; + +Function TRutisBasicStack.ReadInteger(Const adr : Integer) : Integer; +Begin + Result := GetPInteger(Data[Adr]); +End; + +Function TRutisBasicStack.ReadInt64(Const adr : Integer) : Int64; +Begin + Result := GetPInt64(Data[Adr]); +End; + +Function TRutisBasicStack.ReadSingle(Const adr : Integer) : Single; +Begin + Result := GetPSingle(Data[Adr]); +End; + +Function TRutisBasicStack.ReadDouble(Const adr : Integer) : Double; +Begin + Result := GetPDouble(Data[Adr]); +End; + +Function TRutisBasicStack.ReadExtended(Const adr : Integer) : Extended; +Begin + Result := GetPExtended(Data[Adr]); +End; + +Function TRutisBasicStack.ReadAChar(Const adr : Integer) : AnsiChar; +Begin + Result := PAnsiChar(Data[Adr])^; +End; + +Function TRutisBasicStack.ReadWChar(Const adr : Integer) : Widechar; +Begin + Result := GetPWideChar(Data[Adr]); +End; + +Function TRutisBasicStack.ReadString(Const adr : Integer) : RutisString; +Begin + Result := GetPPointer(Data[Adr]); +End; + +Function TRutisBasicStack.ReadShortString(Const adr : Integer) : ShortString; +Begin + Result := GetPShortString(Data[Adr]); +End; + +{$ENDREGION} + +//============================================================================== +{$REGION 'Write functions'} + +Procedure TRutisBasicStack.WriteByte(Const adr : Integer; Const Val : Byte); +Begin + PByte(Data[adr])^ := Val; +End; + +Procedure TRutisBasicStack.WriteWord(Const adr : Integer; Const Val : Word); +Begin + SetPWord(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteCardinal(Const adr : Integer; Const Val : Cardinal); +Begin + SetPCardinal(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteShortInt(Const adr : Integer; Const Val : Shortint); +Begin + PShortInt(Data[adr])^ := Val; +End; + +Procedure TRutisBasicStack.WriteSmallInt(Const adr : Integer; Const Val : Smallint); +Begin + SetPSmallInt(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteInteger(Const adr : Integer; Const Val : Integer); +Begin + SetPInteger(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteInt64(Const adr : Integer; Const Val : Int64); +Begin + SetPInt64(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteSingle(Const adr : Integer; Const Val : Single); +Begin + SetPSingle(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteDouble(Const adr : Integer; Const Val : Double); +Begin + SetPDouble(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteExtended(Const adr : Integer; Const Val : Extended); +Begin + SetPExtended(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteAChar(Const adr : Integer; Const Val : AnsiChar); +Begin + PAnsiChar(Data[adr])^ := Val; +End; + +Procedure TRutisBasicStack.WriteWChar(Const adr : Integer; Const Val : Widechar); +Begin + SetPWideChar(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteString(Const adr : Integer; Const Val : RutisString); +Begin + SetPPointer(Data[adr], Val); +End; + +Procedure TRutisBasicStack.WriteShortString(Const adr : Integer; Const Val : ShortString); +Begin + SetPShortString(Data[adr], Val); +End; + +{$ENDREGION} + +//============================================================================== +{$REGION 'Pop functions'} + +Function TRutisBasicStack.PopByte : Byte; +Begin + Result := PByte(Data[Top - 1])^; + Pop(1); +End; + +Function TRutisBasicStack.PopWord : Word; +Begin + Result := GetPWord(Data[Top - 2]); + Pop(2); +End; + +Function TRutisBasicStack.PopCardinal : Cardinal; +Begin + Result := GetPCardinal(Data[Top - 4]); + Pop(4); +End; + +Function TRutisBasicStack.PopShortInt : Shortint; +Begin + Result := PShortInt(Data[Top - 1])^; + Pop(1); +End; + +Function TRutisBasicStack.PopSmallInt : Smallint; +Begin + Result := GetPSmallInt(Data[Top - 2]); + Pop(2); +End; + +Function TRutisBasicStack.PopInteger : Integer; +Begin + Result := GetPInteger(Data[Top - 4]); + Pop(4); +End; + +Function TRutisBasicStack.PopInt64 : Int64; +Begin + Result := GetPInt64(Data[Top - 8]); + Pop(8); +End; + +Function TRutisBasicStack.PopSingle : Single; +Begin + Result := GetPSingle(Data[Top - 4]); + Pop(4); +End; + +Function TRutisBasicStack.PopDouble : Double; +Begin + Result := GetPDouble(Data[Top - 8]); + Pop(8); +End; + +Function TRutisBasicStack.PopExtended : Extended; +Begin + Result := GetPExtended(Data[Top - 10]); + Pop(10); +End; + +Function TRutisBasicStack.PopAChar : AnsiChar; +Begin + Result := PAnsiChar(Data[Top - 1])^; + Pop(1); +End; + +Function TRutisBasicStack.PopWChar : Widechar; +Begin + Result := GetPWideChar(Data[Top - 2]); + Pop(2); +End; + +Function TRutisBasicStack.PopString : RutisString; +Begin + Result := GetPPointer(Data[Top - 4]); + Pop(4); +End; + +Function TRutisBasicStack.PopShortString : ShortString; +Begin + Result := GetPShortString(Data[Top - 256]); + Pop(256); +End; + +{$ENDREGION} + +//============================================================================== +{$REGION 'Push functions'} + +Procedure TRutisBasicStack.PushByte(Const Val : Byte); +Begin + PByte(Data[Push(1, False)])^ := Val; +End; + +Procedure TRutisBasicStack.PushWord(Const Val : Word); +Begin + SetPWord(Data[Push(2, False)], Val); +End; + +Procedure TRutisBasicStack.PushCardinal(Const Val : Cardinal); +Begin + SetPCardinal(Data[Push(4, False)], Val); +End; + +Procedure TRutisBasicStack.PushShortInt(Const Val : Shortint); +Begin + PShortInt(Data[Push(1, False)])^ := Val; +End; + +Procedure TRutisBasicStack.PushSmallInt(Const Val : Smallint); +Begin + SetPSmallInt(Data[Push(2, False)], Val); +End; + +Procedure TRutisBasicStack.PushInteger(Const Val : Integer); +Begin + SetPInteger(Data[Push(4, False)], Val); +End; + +Procedure TRutisBasicStack.PushInt64(Const Val : Int64); +Begin + SetPInt64(Data[Push(8, False)], Val); +End; + +Procedure TRutisBasicStack.PushSingle(Const Val : Single); +Begin + SetPSingle(Data[Push(4, False)], Val); +End; + +Procedure TRutisBasicStack.PushDouble(Const Val : Double); +Begin + SetPDouble(Data[Push(8, False)], Val); +End; + +Procedure TRutisBasicStack.PushExtended(Const Val : Extended); +Begin + SetPExtended(Data[Push(10, False)], Val); +End; + +Procedure TRutisBasicStack.PushAChar(Const Val : AnsiChar); +Begin + PAnsiChar(Data[Push(1, False)])^ := Val; +End; + +Procedure TRutisBasicStack.PushWChar(Const Val : Widechar); +Begin + SetPWideChar(Data[Push(2, False)], Val); +End; + +Procedure TRutisBasicStack.PushString(Const Val : RutisString; Const AutoFree : Boolean); +Begin + SetPPointer(Data[Push(4, False)], Val); + If AutoFree Then + AddFreeData(Top - 4, True); +End; + +Procedure TRutisBasicStack.PushShortString(Const Val : ShortString); +Begin + SetPShortString(Data[Push(SizeOf(ShortString), False)], Val); +End; + +Procedure TRutisBasicStack.PushAStringData(Const Val : Ansistring); +Begin + If Val = '' Then + PushCardinal(0) + Else + CopyStackData(PByte(Cardinal(Val) - 4), Data[Push(length(Val) + 4, False)], length(Val) + 4); + PushByte(0); + {$ifdef WinCE} + while Top mod 4 <> 0 do + PushByte(0); + {$endif WinCE} +End; + +{$ENDREGION} + +//============================================================================== + +Function TRutisBasicStack.PointerInBlockData(p : Pointer) : Boolean; +Var i : Integer; +Begin + Result := True; + For i := 0 To TopBlock Do + Begin + If (Cardinal(p) >= Cardinal(Blocks[i].Data)) and + (Cardinal(p) < Cardinal(Blocks[i].Data) + fStackBlockSize) Then exit; + End; + Result := False; +End; + +//============================================================================== + +Procedure TRutisBasicStack.AddFreeData(adr : Integer; IsStr : Boolean); +Begin + SetLength(FreeInfo, length(FreeInfo) + 1); + FreeInfo[high(FreeInfo)].Adr := Adr; + FreeInfo[high(FreeInfo)].IsStr := IsStr; +End; + +Procedure TRutisBasicStack.Update_FreeData; +Var + i : Integer; + dst : PPointer; +Begin + dst := nil; + For i := high(FreeInfo) Downto 0 Do + If Top <= FreeInfo[i].Adr Then + Begin + Try + dst := PPointer(GetCardinal(FreeInfo[i].Adr)); + + If dst^ <> nil Then + Begin + If FreeInfo[i].IsStr Then + Ansistring(dst^) := '' + Else + FreeMem(dst^); + End; + Finally + If dst <> nil Then + dst^ := nil; + FreeInfo[i] := FreeInfo[high(FreeInfo)]; + SetLength(FreeInfo, length(FreeInfo) - 1); + End; + End; +End; + +{$ENDREGION} + +End. + + +