moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-24 02:02:17 -05:00
Code Issues Releases Wiki Activity
c7a6f55b66
Simba/Units/RUTIS/Rutis_Compiler_Delphi.pas
Merlijn Wajer bb4a3ed614 Fix casing in unit names
2010-08-27 14:41:55 +02:00

4179 lines
117 KiB
ObjectPascal
Raw Blame History

{/==============================================================================
//==============================================================================
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.
Reference in New Issue View Git Blame Copy Permalink