Unit MPL_Execute;
{$I M_OPS.PAS}
Interface
Uses
DOS,
MPL_FileIO,
BBS_Common;
{$I MPL_TYPES.PAS}
Const
mplExecuteBuffer = 8 * 1024;
Type
TInterpEngine = Class
Owner : Pointer;
ErrStr : String;
ErrNum : Byte;
DataFile : PCharFile;
CurVarNum : Word;
CurVarID : Word;
CurRecNum : Word;
VarData : VarDataRec;
RecData : RecDataRec;
Ch : Char;
W : Word;
IoError : LongInt;
ReloadMenu : Boolean;
DirInfo : SearchRec;
IdxVarDir : Word;
IdxVarUser : Word;
IdxVarMBase : Word;
IdxVarMGroup : Word;
IdxVarFBase : Word;
IdxVarFGroup : Word;
ParamsStr : String;
MPEName : String;
Done : Boolean;
ExitProc : Boolean;
SavedMCI : Boolean;
SavedGroup : Boolean;
SavedArrow : Boolean;
Function GetErrorMsg : String;
Procedure Error (Err: Byte; Str: String);
Procedure MoveToPos (Num: LongInt);
Procedure SkipBlock;
Function CurFilePos : LongInt;
Procedure NextChar;
Procedure NextWord;
Procedure PrevChar;
Function GetDataPtr (VN: Word; Var A: TArrayInfo) : Pointer;
Function GetDataSize (VarNum: Word) : Word;
Function FindVariable (ID: Word) : Word;
Procedure CheckArray (VN: Word; Var A: TArrayInfo);
Function GetNumber (VN: Word; Var A: TArrayInfo) : Real;
Function RecastNumber (Var Num; T: TIdentTypes) : Real;
Function EvaluateNumber : Real;
Function EvaluateString : String;
Function EvaluateBoolean : Boolean;
Procedure SetString (VarNum: Word; Var A: TArrayInfo; Str: String);
Procedure SetNumber (VN: Word; R: Real; Var A: TArrayInfo);
Procedure SetVariable (VarNum: Word);
Function DefineVariable : LongInt;
Procedure DefineProcedure;
Procedure DefineRecord;
Procedure StatementRepeatUntil;
Function StatementIfThenElse : Byte;
Function StatementCase : Byte;
Procedure StatementForLoop;
Procedure StatementWhileDo;
Function ExecuteProcedure (DP: Pointer) : TIdentTypes;
Function ExecuteBlock (StartVar, StartRec: Word) : Byte;
// BBS DATA ACCESS FUNCTIONS
Procedure FileReadLine (Var F: File; Var Str: String);
Procedure FileWriteLine (Var F: File; Str: String);
Procedure GetUserVars (Var U: RecUser);
Function GetUserRecord (Num: LongInt) : Boolean;
Procedure GetMBaseVars (Var M: MBaseRec);
Function GetMBaseRecord (Num: LongInt) : Boolean;
Procedure GetMGroupVars (Var G: RecGroup);
Function GetMGroupRecord (Num: LongInt) : Boolean;
Procedure GetFBaseVars (Var F: FBaseRec);
Function GetFBaseRecord (Num: LongInt) : Boolean;
Procedure GetFGroupVars (Var G: RecGroup);
Function GetFGroupRecord (Num: LongInt) : Boolean;
Constructor Create (O: Pointer);
Destructor Destroy; Override;
Function Execute (FN: String) : Byte;
End;
Function ExecuteMPL (Owner: Pointer; Str: String) : Byte;
Implementation
Uses
m_Bits,
m_Strings,
m_DateTime,
m_Types,
m_FileIO,
BBS_Core,
BBS_IO,
BBS_General;
{$I MPL_COMMON.PAS}
Procedure TInterpEngine.GetUserVars (Var U: RecUser);
Begin
Move (U.PermIdx, VarData[IdxVarUser ]^.Data^, SizeOf(U.PermIdx));
Move (U.RealName, VarData[IdxVarUser + 1 ]^.Data^, SizeOf(U.RealName));
Move (U.Handle, VarData[IdxVarUser + 2 ]^.Data^, SizeOf(U.Handle));
Move (U.Address, VarData[IdxVarUser + 3 ]^.Data^, SizeOf(U.Address));
Move (U.Security, VarData[IdxVarUser + 4 ]^.Data^, SizeOf(U.Security));
Move (U.Gender, VarData[IdxVarUser + 5 ]^.Data^, SizeOf(U.Gender));
Move (U.FirstOn, VarData[IdxVarUser + 6 ]^.Data^, SizeOf(U.FirstOn));
Move (U.LastOn, VarData[IdxVarUser + 7 ]^.Data^, SizeOf(U.LastOn));
Move (U.DateType, VarData[IdxVarUser + 8 ]^.Data^, SizeOf(U.DateType));
Move (U.Calls, VarData[IdxVarUser + 9 ]^.Data^, SizeOf(U.Calls));
Move (U.Password, VarData[IdxVarUser + 10]^.Data^, SizeOf(U.Password));
Move (U.Flags, VarData[IdxVarUser + 11]^.Data^, SizeOf(U.Flags));
End;
Function TInterpEngine.GetUserRecord (Num: LongInt) : Boolean;
Var
F : File;
U : RecUser;
Begin
Result := False;
Assign (F, Config.DataPath + 'users.dat');
If Not ioReset(F, SizeOf(RecUser), fmRWDN) Then Exit;
If ioSeek(F, Pred(Num)) And (ioRead(F, U)) Then Begin
GetUserVars(U);
Result := True;
End;
Close (F);
End;
Procedure TInterpEngine.GetMBaseVars (Var M: MBaseRec);
Begin
Move (M.Index, VarData[IdxVarMBase ]^.Data^, SizeOf(M.Index));
Move (M.Name, VarData[IdxVarMBase + 1 ]^.Data^, SizeOf(M.Name));
Move (M.ACS, VarData[IdxVarMBase + 2 ]^.Data^, SizeOf(M.ACS));
Move (M.ReadACS, VarData[IdxVarMBase + 3 ]^.Data^, SizeOf(M.ReadACS));
Move (M.PostACS, VarData[IdxVarMBase + 4 ]^.Data^, SizeOf(M.PostACS));
Move (M.SysopACS, VarData[IdxVarMBase + 5 ]^.Data^, SizeOf(M.SysopACS));
End;
Function TInterpEngine.GetMBaseRecord (Num: LongInt) : Boolean;
Var
F : File;
M : MBaseRec;
Begin
Result := False;
Assign (F, Config.DataPath + 'mbases.dat');
If Not ioReset(F, SizeOf(MBaseRec), fmRWDN) Then Exit;
If ioSeek(F, Num) And (ioRead(F, M)) Then Begin
GetMBaseVars(M);
Result := True;
End;
Close (F);
End;
Procedure TInterpEngine.GetMGroupVars (Var G: RecGroup);
Begin
Move (G.Name, VarData[IdxVarMGroup ]^.Data^, SizeOf(G.Name));
Move (G.ACS, VarData[IdxVarMGroup + 1 ]^.Data^, SizeOf(G.ACS));
Move (G.Hidden, VarData[IdxVarMGroup + 2 ]^.Data^, SizeOf(G.Hidden));
End;
Function TInterpEngine.GetMGroupRecord (Num: LongInt) : Boolean;
Var
F : File;
G : RecGroup;
Begin
Result := False;
Assign (F, Config.DataPath + 'groups_g.dat');
If Not ioReset(F, SizeOf(RecGroup), fmRWDN) Then Exit;
If ioSeek(F, Pred(Num)) And (ioRead(F, G)) Then Begin
GetMGroupVars(G);
Result := True;
End;
Close (F);
End;
Procedure TInterpEngine.GetFBaseVars (Var F: FBaseRec);
Begin
Move (F.Name, VarData[IdxVarFBase ]^.Data^, SizeOf(F.Name));
Move (F.ListACS, VarData[IdxVarFBase + 1 ]^.Data^, SizeOf(F.ListACS));
End;
Function TInterpEngine.GetFBaseRecord (Num: LongInt) : Boolean;
Var
F : File;
FB : FBaseRec;
Begin
Result := False;
Assign (F, Config.DataPath + 'fbases.dat');
If Not ioReset(F, SizeOf(FBaseRec), fmRWDN) Then Exit;
If ioSeek(F, Pred(Num)) And (ioRead(F, FB)) Then Begin
GetFBaseVars(FB);
Result := True;
End;
Close (F);
End;
Procedure TInterpEngine.GetFGroupVars (Var G: RecGroup);
Begin
Move (G.Name, VarData[IdxVarFGroup ]^.Data^, SizeOf(G.Name));
Move (G.ACS, VarData[IdxVarFGroup + 1 ]^.Data^, SizeOf(G.ACS));
Move (G.Hidden, VarData[IdxVarFGroup + 2 ]^.Data^, SizeOf(G.Hidden));
End;
Function TInterpEngine.GetFGroupRecord (Num: LongInt) : Boolean;
Var
F : File;
G : RecGroup;
Begin
Result := False;
Assign (F, Config.DataPath + 'groups_f.dat');
If Not ioReset(F, SizeOf(RecGroup), fmRWDN) Then Exit;
If ioSeek(F, Pred(Num)) And (ioRead(F, G)) Then Begin
GetFGroupVars(G);
Result := True;
End;
Close (F);
End;
Constructor TInterpEngine.Create (O: Pointer);
Begin
Inherited Create;
Owner := O;
ErrNum := 0;
ErrStr := '';
Ch := #0;
W := 0;
End;
Destructor TInterpEngine.Destroy;
Var
Count : LongInt;
Begin
For Count := 1 to CurVarNum Do Begin
If (VarData[Count]^.Kill) And (VarData[Count]^.Data <> NIL) Then
FreeMem(VarData[Count]^.Data, VarData[Count]^.DataSize);
Dispose(VarData[Count]);
End;
For Count := 1 to CurRecNum Do
Dispose(RecData[Count]);
CurVarNum := 0;
CurRecNum := 0;
Inherited Destroy;
End;
Function TInterpEngine.GetErrorMsg : String;
Begin
Result := '';
Case ErrNum of
mpxEndOfFile : Result := 'Unexpected end of file';
mpxInvalidFile : Result := 'Invalid executable: ' + ErrStr;
mpxVerMismatch : Result := 'Version mismatch: ' + ErrStr + ' / ' + mplVersion;
mpxUnknownOp : Result := 'Unknown Token: ' + ErrStr;
mpxMultiInit : Result := 'Unable to initialize variable';
mpxDivisionByZero : Result := 'Division by zero';
mpxMathematical : Result := 'Parsing error';
End;
End;
Procedure TInterpEngine.Error (Err: Byte; Str: String);
Begin
If ErrNum > 0 Then Exit;
ErrNum := Err;
ErrStr := Str;
End;
Procedure TInterpEngine.MoveToPos (Num: LongInt);
Begin
DataFile^.Seek (Num + mplVerLength);
End;
Function TInterpEngine.CurFilePos : LongInt;
Begin
Result := DataFile^.FilePos - mplVerLength;
End;
Procedure TInterpEngine.NextChar;
Begin
Ch := DataFile^.Read;
End;
Procedure TInterpEngine.NextWord;
Var
Res : LongInt;
Begin
DataFile^.BlockRead (W, 2, Res);
End;
Procedure TInterpEngine.PrevChar;
Begin
MoveToPos (CurFilePos - 1);
End;
Function TInterpEngine.FindVariable (ID: Word) : Word;
Var
Count : LongInt;
Begin
Result := 0;
Count := CurVarNum;
If CurVarNum = 0 Then Exit;
Repeat
If VarData[Count]^.VarID = ID Then Begin
Result := Count;
Exit;
End;
Dec (Count);
Until (Count = 0);
End;
Function TInterpEngine.GetDataPtr (VN: Word; Var A: TArrayInfo) : Pointer;
Begin
With VarData[VN]^ Do
Case ArrPos of
0 : Result := Data;
1 : Result := @Data^[VarSize * (A[1] - 1) + 1];
2 : Result := @Data^[VarSize * ((A[1] - 1) * ArrDim[2] + A[2])];
3 : Result := @Data^[VarSize * ((A[1] - 1) * (ArrDim[2] * ArrDim[3]) + (A[2] - 1) * ArrDim[3] + A[3])];
End;
End;
Procedure TInterpEngine.CheckArray (VN: Word; Var A: TArrayInfo);
Var
Count : Word;
Begin
For Count := 1 to mplMaxArrayDem Do A[Count] := 1;
If VarData[VN]^.ArrPos = 0 Then Exit;
For Count := 1 to VarData[VN]^.ArrPos Do
A[Count] := Trunc(EvaluateNumber);
End;
Function TInterpEngine.GetNumber(VN: Word; Var A: TArrayInfo) : Real;
Begin
Case VarData[VN]^.vType of
iByte : Result := Byte(GetDataPtr(VN, A)^);
iShort : Result := ShortInt(GetDataPtr(VN, A)^);
iWord : Result := Word(GetDataPtr(VN, A)^);
iInteger : Result := Integer(GetDataPtr(VN, A)^);
iLongInt : Result := LongInt(GetDataPtr(VN, A)^);
iReal : Result := Real(GetDataPtr(VN, A)^);
End;
End;
Function TInterpEngine.RecastNumber (Var Num; T: TIdentTypes) : Real;
Begin
Case T of
iByte : Result := Byte(Num);
iShort : Result := ShortInt(Num);
iWord : Result := Word(Num);
iInteger : Result := Integer(Num);
iLongInt : Result := LongInt(Num);
iReal : Result := Real(Num);
End;
End;
Function TInterpEngine.EvaluateNumber : Real;
Var
CheckChar : Char;
VarNum : Word;
PowerRes : Real;
Procedure ParseNext;
Begin
NextChar;
If Ch = Char(opCloseNum) Then CheckChar := ^M Else CheckChar := Ch;
End;
Function AddSubtract : Real;
Var
OpChar : Char;
Function MultiplyDivide : Real;
Var
OpChar : Char;
Function Power : Real;
Function SignedOp : Real;
Function UnsignedOp : Real;
Var
Start : LongInt;
ArrayInfo : TArrayInfo;
NumStr : String;
Begin
Case TTokenOpsRec(Byte(CheckChar)) of
opLeftParan : Begin
ParseNext;
Result := AddSubtract;
ParseNext;
End;
opVariable : Begin
NextWord;
VarNum := FindVariable(w);
CheckArray(VarNum, ArrayInfo);
Result := GetNumber(VarNum, ArrayInfo);
ParseNext;
End;
opProcExec : Begin
Result := RecastNumber(Result, ExecuteProcedure(@Result));
ParseNext;
End;
Else
NumStr := '';
Repeat
NumStr := NumStr + CheckChar;
ParseNext;
Until Not (CheckChar in ['0'..'9', '.', 'E']);
Val(NumStr, Result, Start);
End;
End;
Begin
If CheckChar = '-' Then Begin
ParseNext;
Result := -UnsignedOp;
End Else
Result := UnsignedOp;
End;
Begin
Result := SignedOp;
While CheckChar = '^' Do Begin
ParseNext;
If Result <> 0 Then
Result := Exp(Ln(Abs(Result)) * SignedOp)
Else
Result := 0;
End;
End;
Begin
Result := Power;
While CheckChar in ['%','*','/'] Do Begin
OpChar := CheckChar;
ParseNext;
Case OpChar of
'%' : Result := Trunc(Result) MOD Trunc(Power);
'*' : Result := Result * Power;
'/' : Begin
PowerRes := Power;
If PowerRes = 0 Then
Error (mpxDivisionByZero, '')
Else
Result := Result / PowerRes;
End;
End;
End;
End;
Begin
Result := MultiplyDivide;
While CheckChar in ['+','-','&','|','@','<','>'] Do Begin
OpChar := CheckChar;
ParseNext;
Case OpChar of
'+' : Result := Result + MultiplyDivide;
'-' : Result := Result - MultiplyDivide;
'&' : Result := Trunc(Result) AND Trunc(MultiplyDivide);
'|' : Result := Trunc(Result) OR Trunc(MultiplyDivide);
'@' : Result := Trunc(Result) XOR Trunc(MultiplyDivide);
'<' : Result := Trunc(Result) SHL Trunc(MultiplyDivide);
'>' : Result := Trunc(Result) SHR Trunc(MultiplyDivide);
End;
End;
End;
Begin
NextChar;
ParseNext;
Result := AddSubtract;
End;
Function TInterpEngine.EvaluateString : String;
Var
VarNum : Word;
ArrayData : TArrayInfo;
Res : LongInt;
Begin
Result := '';
NextChar;
Case TTokenOpsRec(Byte(Ch)) of
opVariable : Begin
NextWord;
VarNum := FindVariable(W);
CheckArray (VarNum, ArrayData);
If VarData[VarNum].vType = iChar Then Begin
Result[0] := #1;
Result[1] := Char(GetDataPtr(VarNum, ArrayData)^);
End Else
Result := String(GetDataPtr(VarNum, ArrayData)^);
End;
opOpenString : Begin
NextChar;
Result[0] := Ch;
DataFile^.BlockRead (Result[1], Byte(Ch), Res);
End;
opProcExec : Case ExecuteProcedure(@Result) of
iChar : Begin // convert to string if its a char
Result[1] := Result[0];
Result[0] := #1;
End;
End;
End;
NextChar;
If Ch = Char(opStrArray) Then Begin
Result := Result[Trunc(EvaluateNumber)];
NextChar;
End;
If Ch = Char(opStrAdd) Then
Result := Result + EvaluateString
Else
PrevChar;
End;
Function TInterpEngine.EvaluateBoolean : Boolean;
Type
tOp = (
tOpNone,
tOpEqual,
tOpNotEqual,
tOpGreater,
tOpLess,
tOpEqGreat,
tOpEqLess
);
Var
VarNum : Word;
VarType1 : TIdentTypes;
VarType2 : TIdentTypes;
OpType : tOp;
GotA : Boolean;
GotB : Boolean;
BooleanA : Boolean;
BooleanB : Boolean;
IsNot : Boolean;
RealA : Real;
RealB : Real;
StringA : String;
StringB : String;
ArrayData : TArrayInfo;
Begin
// set default result?
VarType1 := iNone;
VarType2 := iNone;
GotA := False;
GotB := False;
OpType := tOpNone;
IsNot := False;
Repeat
NextChar;
// put these in numerical order...
Case TTokenOpsRec(Byte(Ch)) of
opLeftParan : Begin
BooleanA := EvaluateBoolean;
VarType1 := iBool;
GotA := True;
NextChar;
End;
opVariable : Begin
NextWord;
VarNum := FindVariable(W);
CheckArray(VarNum, ArrayData);
VarType1 := VarData[VarNum]^.vType;
If VarType1 = iBool Then
BooleanA := ByteBool(GetDataPtr(VarNum, ArrayData)^)
Else
If (VarType1 in vStrings) Then Begin
NextChar;
If Ch = Char(opStrArray) Then
StringA := String(GetDataPtr(VarNum, ArrayData)^)[Trunc(EvaluateNumber)]
Else Begin
PrevChar;
If VarData[VarNum]^.vType = iChar Then Begin
StringA[0] := #1;
StringA[1] := Char(GetDataPtr(VarNum, ArrayData)^);
End Else
StringA := String(GetDataPtr(VarNum, ArrayData)^);
End;
End Else
If VarType1 in vNums Then
RealA := GetNumber(VarNum, ArrayData); // evalnumber here
GotA := True;
End;
opProcExec : Begin
VarType1 := ExecuteProcedure(@StringA);
If VarType1 = iBool Then BooleanA := Boolean(Byte(StringA[0])) else
If VarType1 in vNums Then RealA := RecastNumber(StringA, VarType1) else
if VarType1 = iChar Then Begin
StringA[1] := StringA[0];
StringA[0] := #1;
End;
GotA := True;
End;
opTrue : Begin // we can combine true/false here...
BooleanA := True;
VarType1 := iBool;
GotA := True;
End;
opFalse : Begin
BooleanA := False;
VarType1 := iBool;
GotA := True;
End;
opOpenString : Begin
PrevChar;
StringA := EvaluateString;
VarType1 := iString;
GotA := True;
End;
opOpenNum : Begin
PrevChar;
RealA := EvaluateNumber;
VarType1 := iReal;
GotA := True;
End;
opNot : IsNot := Not IsNot;
End;
Until (ErrNum <> 0) or GotA;
If ErrNum <> 0 Then Exit;
NextChar;
// we shouldnt even need this... just use the actual tokens...???
Case TTokenOpsRec(Byte(Ch)) of
opEqual : OpType := tOpEqual;
opNotEqual : OpType := tOpNotEqual;
opGreater : OpType := tOpGreater;
opLess : OpType := tOpLess;
opEqGreat : OpType := tOpEqGreat;
opEqLess : OpType := tOpEqLess;
Else
Result := BooleanA;
PrevChar;
End;
If OpType <> tOpNone Then Begin
Repeat
NextChar;
Case TTokenOpsRec(Byte(Ch)) of
opLeftParan : Begin
BooleanB := EvaluateBoolean;
VarType2 := iBool;
GotB := True;
NextChar;
End;
opVariable : Begin
NextWord;
VarNum := FindVariable(w);
CheckArray (VarNum, ArrayData);
VarType2 := VarData[VarNum]^.vType;
If VarType2 = iBool Then
BooleanB := ByteBool(GetDataPtr(VarNum,ArrayData)^)
Else
If (VarType2 in vStrings) Then Begin
NextChar;
If Ch = Char(opStrArray) Then
StringB := String(GetDataPtr(VarNum, ArrayData)^)[Trunc(EvaluateNumber)]
Else Begin
PrevChar;
If VarData[VarNum]^.vType = iChar Then Begin
StringB[0] := #1;
StringB[1] := Char(GetDataPtr(VarNum, ArrayData)^);
End Else
StringB := String(GetDataPtr(VarNum, ArrayData)^);
End;
End Else
If VarType2 in vNums Then
RealB := GetNumber(VarNum, ArrayData);
GotB := True;
End;
opProcExec : Begin
VarType2 := ExecuteProcedure(@StringB);
If VarType2 = iBool Then BooleanB := Boolean(Byte(StringB[0])) Else
If VarType2 in vNums Then RealB := RecastNumber(StringB, VarType2) Else
if VarType2 = iChar Then Begin
StringB[1] := StringB[0];
StringB[0] := #1;
End;
GotB := True;
End;
opTrue : Begin
BooleanB := True;
VarType2 := iBool;
GotB := True;
End;
opFalse : Begin
BooleanB := False;
VarType2 := iBool;
GotB := True;
End;
opOpenString : Begin
PrevChar;
StringB := EvaluateString;
VarType2 := iString;
GotB := True;
End;
opOpenNum : Begin
PrevChar;
RealB := EvaluateNumber;
VarType2 := iReal;
GotB := True;
End;
End;
Until (ErrNum <> 0) or GotB;
If ErrNum <> 0 Then Exit;
Result := False;
Case OpType of
tOpEqual : If (VarType1 in vStrings) Then
Result := StringA = StringB
Else
If VarType1 = iBool Then
Result := BooleanA = BooleanB
Else
Result := RealA = RealB;
tOpNotEqual : If (VarType1 in vStrings) Then Result := StringA <> StringB Else
If VarType1 = iBool Then Result := BooleanA <> BooleanB Else
Result := RealA <> RealB;
tOpGreater : If (VarType1 in vStrings) Then Result := StringA > StringB Else
If VarType1 = iBool Then Result := BooleanA > BooleanB Else
Result := RealA > RealB;
tOpLess : If (VarType1 in vStrings) Then Result := StringA < StringB Else
If VarType1 = iBool Then Result := BooleanA < BooleanB Else
Result := RealA < RealB;
tOpEqGreat : If (VarType1 in vStrings) Then Result := StringA >= StringB Else
If VarType1 = iBool Then Result := BooleanA >= BooleanB Else
Result := RealA >= RealB;
tOpEqLess : If (VarType1 in vStrings) Then Result := StringA <= StringB Else
If VarType1 = iBool Then Result := BooleanA <= BooleanB Else
Result := RealA <= RealB;
End;
End;
If IsNot Then Result := Not Result;
NextChar;
Case TTokenOpsRec(Byte(Ch)) of
opAnd : Result := EvaluateBoolean And Result;
opOr : Result := EvaluateBoolean Or Result;
Else
PrevChar;
End;
End;
Procedure TInterpEngine.SetString (VarNum: Word; Var A: TArrayInfo; Str: String);
Begin
If VarData[VarNum].vType = iString Then Begin
If Ord(Str[0]) >= VarData[VarNum]^.VarSize Then
Str[0] := Chr(VarData[VarNum]^.VarSize - 1);
Move (Str, GetDataPtr(VarNum, A)^, VarData[VarNum]^.VarSize);
End Else
Move (Str[1], GetDataPtr(VarNum, A)^, 1);
End;
Procedure TInterpEngine.SetVariable (VarNum: Word);
Var
ArrayData : TArrayInfo;
Target : Byte;
TempStr : String;
Begin
CheckArray (VarNum, ArrayData);
Case VarData[VarNum]^.vType of
iChar,
iString: Begin
NextChar;
If Ch = Char(opStrArray) Then Begin
TempStr := String(GetDataPtr(VarNum, ArrayData)^);
Target := Byte(Trunc(EvaluateNumber));
TempStr[Target] := EvaluateString[1];
SetString (VarNum, ArrayData, TempStr);
End Else Begin
PrevChar;
SetString (VarNum, ArrayData, EvaluateString);
End;
End;
iByte : Byte(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber);
iShort : ShortInt(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber);
iWord : Word(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber);
iInteger : Integer(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber);
iLongInt : LongInt(GetDataPtr(VarNum, ArrayData)^) := Trunc(EvaluateNumber);
iReal : Real(GetDataPtr(VarNum, ArrayData)^) := EvaluateNumber;
iBool : ByteBool(GetDataPtr(VarNum, ArrayData)^) := EvaluateBoolean;
End;
End;
Procedure TInterpEngine.SetNumber (VN: Word; R: Real; Var A: TArrayInfo);
Begin
Case VarData[VN]^.vType of
iByte : Byte(GetDataPtr(VN, A)^) := Trunc(R);
iShort : ShortInt(GetDataPtr(VN, A)^) := Trunc(R);
iWord : Word(GetDataPtr(VN, A)^) := Trunc(R);
iInteger : Integer(GetDataPtr(VN, A)^) := Trunc(R);
iLongInt : LongInt(GetDataPtr(VN, A)^) := Trunc(R);
iReal : Real(GetDataPtr(VN, A)^) := R;
end;
end;
Function TInterpEngine.GetDataSize (VarNum: Word) : Word;
Var
Count : Word;
Begin
With VarData[VarNum]^ Do Begin
Result := VarSize;
For Count := 1 To ArrPos Do
Result := Result * ArrDim[Count];
End;
End;
Function TInterpEngine.DefineVariable : LongInt;
Var
VarType : TIdentTypes;
NumVars : Word;
SavedVar : Word;
StrSize : Word;
Count : Word;
ArrayPos : Word;
ArrayData : TArrayInfo;
Begin
Result := 0;
NextChar;
VarType := cVarType(Ch);
NextChar;
StrSize := 256;
ArrayPos := 0;
For Count := 1 To mplMaxArrayDem Do ArrayData[Count] := 1;
If Ch = Char(opStrSize) Then Begin
StrSize := Trunc(EvaluateNumber) + 1;
NextChar;
End;
If Ch = Char(opArrDef) Then Begin
NextWord;
ArrayPos := W;
For Count := 1 to ArrayPos Do ArrayData[Count] := Trunc(EvaluateNumber);
End;
NextWord;
NumVars := W;
SavedVar := CurVarNum + 1;
For Count := 1 to NumVars Do
If ErrNum = 0 Then Begin
NextWord;
If FindVariable(W) > 0 Then Begin
Error (mpxMultiInit, '');
Exit;
End;
Inc (CurVarNum);
New (VarData[CurVarNum]);
With VarData[CurVarNum]^ Do Begin
VarID := W;
vType := VarType;
NumParams := 0;
ProcPos := 0;
If VarType = iString Then
VarSize := StrSize
Else
VarSize := xVarSize(VarType);
Kill := True;
ArrPos := ArrayPos;
ArrDim := ArrayData;
DataSize := GetDataSize(CurVarNum);
Result := DataSize;
GetMem (Data, DataSize);
FillChar (Data^, DataSize, 0);
End;
End;
NextChar;
If Ch = Char(OpEqual) Then Begin
SetVariable(SavedVar);
For Count := SavedVar + 1 To CurVarNum Do
Move (VarData[SavedVar]^.Data^, VarData[Count]^.Data^, VarData[SavedVar]^.DataSize);
End Else
PrevChar;
End;
Procedure TInterpEngine.FileReadLine (Var F: File; Var Str: String);
Var
Buf : String;
BR : SmallInt;
Count : Byte;
SP : LongInt;
Begin
Str := '';
SP := FilePos(F);
Count := 1;
BlockRead (F, Buf[1], 255, BR);
While Count <= BR Do Begin
Inc (SP);
If Buf[Count] = #10 Then Break;
If Buf[Count] <> #13 Then
Str := Str + Buf[Count];
If Count = 255 Then Begin
BlockRead (F, Buf[1], 255, BR);
Count := 0;
End;
Inc (Count);
End;
Seek (F, SP);
IoError := IoResult;
End;
Procedure TInterpEngine.FileWriteLine (Var F: File; Str: String);
Begin
{$IFDEF WIN32}
Str := Str + #13#10;
{$ENDIF}
{$IFDEF UNIX}
Str := Str + #10;
{$ENDIF}
BlockWrite (F, Str[1], Ord(Str[0]));
IoError := IoResult;
End;
Function TInterpEngine.ExecuteProcedure (DP: Pointer) : TIdentTypes;
// okay... change this to:
// array[1..mplmaxprocparams] of record
// vsize : word;
// vdata : pointer;
// end;
// VAR passing: stores dataptr to passed variable -- DONE
// regular : creates var and stores its pointer into vdata -- TODO
// doing this will reduce memory usage and make things even harder to
// understand.
// this stuff really needs to be cleaned up before records are fully
// added
Type
TParamInfo = Array[1..mplMaxProcParams] of Record
// vType : TIdentTypes;
vSize : Word; //do we really nede this? can get size from vType
vID : Word;
vData : PStack;
Case TIdentTypes of // this all needs to go... push to vData
iChar : (C : Char);
iString : (S : String);
iByte : (B : Byte);
iShort : (H : ShortInt);
iWord : (W : Word);
iInteger : (I : Integer);
iLongInt : (L : LongInt);
iReal : (R : Real);
iBool : (O : Boolean);
End;
Var
VarNum : Word;
Count : Word;
ProcID : Word;
SavedVar : Word;
Param : TParamInfo;
TempStr : String;
TempBool : Boolean;
TempByte : Byte;
TempLong : LongInt;
TempChar : Char;
TempInt : SmallInt;
Sub : LongInt;
ArrayData : TArrayInfo;
Procedure Store (Var Dat; Siz: Word);
Begin
If DP <> NIL Then Move (Dat, DP^, Siz);
End;
Begin
// no default result value set here
NextWord;
ProcID := W;
VarNum := FindVariable(ProcID);
For Count := 1 to VarData[VarNum]^.NumParams Do Begin
With VarData[VarNum]^ Do Begin
If Params[Count] = UpCase(Params[Count]) Then Begin
// its a VAR type parameter, so find the variable
// and directly map the data pointer to the passed vars
// data pointer
NextWord;
Param[Count].vID := FindVariable(W);
CheckArray(Param[Count].vID, ArrayData);
Param[Count].vData := GetDataPtr(Param[Count].vID, ArrayData);
If VarData[Param[Count].vID]^.vType = iString Then
Param[Count].vSize := VarData[Param[Count].vID]^.VarSize;
End Else Begin
// this should getmem dataptr and store it there instead
// will save some memory but make calling functions below a bit more
// of a pain in the ass
Case Params[Count] of
'c' : Begin
Param[Count].vSize := 1;
Param[Count].C := EvaluateString[1];
End;
's' : Begin
Param[Count].vSize := 256;
Param[Count].S := EvaluateString;
End;
'b' : Param[Count].B := Trunc(EvaluateNumber);
'h' : Param[Count].H := Trunc(EvaluateNumber);
'w' : Param[Count].W := Trunc(EvaluateNumber);
'i' : Param[Count].I := Trunc(EvaluateNumber);
'l' : Param[Count].L := Trunc(EvaluateNumber);
'r' : Param[Count].R := EvaluateNumber;
'o' : Param[Count].O := EvaluateBoolean;
End;
End;
NextChar;
End;
End;
Result := VarData[VarNum]^.vType;
// this means that its a physical procedure and not a variable
// or a predefined procedure from mpl_common.
If VarData[VarNum]^.ProcPos > 0 Then Begin
Sub := CurFilePos;
SavedVar := CurVarNum;
MoveToPos(VarData[VarNum]^.ProcPos);
For Count := 1 to VarData[VarNum]^.NumParams Do Begin
Inc (CurVarNum);
New (VarData[CurVarNum]);
With VarData[CurVarNum]^ Do Begin
VarID := VarData[VarNum]^.pID[Count];
vType := cVarType(VarData[VarNum]^.Params[Count]);
NumParams := 0;
ProcPos := 0;
ArrPos := 0;
If vType = iString Then
VarSize := Param[Count].vSize
Else
VarSize := xVarSize(vType);
DataSize := GetDataSize(CurVarNum);
If VarData[VarNum]^.Params[Count] = UpCase(VarData[VarNum]^.Params[Count]) Then Begin
// Data := VarData[Param[Count].vID]^.Data;
Data := Param[Count].vData;
Kill := False;
End Else Begin
GetMem (Data, DataSize);
Case VarData[VarNum]^.Params[Count] of
'c' : Char(Pointer(Data)^) := Param[Count].C;
's' : Begin
If Ord(Param[Count].S[0]) >= VarSize Then
Param[Count].S[0] := Chr(VarSize - 1);
Move (Param[Count].S, Data^, VarSize);
End;
'b' : Byte(Pointer(Data)^) := Param[Count].B;
'h' : ShortInt(Pointer(Data)^) := Param[Count].H;
'w' : Word(Pointer(Data)^) := Param[Count].W;
'i' : Integer(Pointer(Data)^) := Param[Count].I;
'l' : LongInt(Pointer(Data)^) := Param[Count].L;
'r' : Real(Pointer(Data)^) := Param[Count].R;
'o' : Boolean(Pointer(Data)^) := Param[Count].O;
end;
Kill := True;
End;
End;
End;
If VarData[VarNum]^.vType <> iNone Then Begin
VarData[VarNum]^.DataSize := GetDataSize(VarNum);
VarData[VarNum]^.Kill := False;
GetMem (VarData[VarNum]^.Data, VarData[VarNum]^.DataSize);
FillChar (VarData[VarNum]^.Data^, VarData[VarNum]^.DataSize, 0);
End;
ExecuteBlock (SavedVar, CurRecNum);
If ExitProc Then Begin
ExitProc := False;
Done := False;
End;
If VarData[VarNum]^.vType <> iNone Then Begin
If DP <> NIL Then // force char into a string for DP
if VarData[VarNum]^.vType = iChar Then Begin
TempStr[0] := #1;
TempStr[1] := Char(Pointer(VarData[VarNum]^.Data)^);
Move (TempStr, DP^, 2);
End Else
Move (VarData[VarNum]^.Data^, DP^, VarData[VarNum]^.DataSize);
FreeMem(VarData[VarNum]^.Data, VarData[VarNum]^.DataSize);
VarData[VarNum]^.DataSize := 0;
End;
MoveToPos(Sub);
Exit;
End; // end of custom procedure execution
// its not a custom procedure, its a build in proc so lets do it
// this means that all of this param stuff will have to be redone
// if we change it to a dataptr. what effect will this have on
// execution speed?
{$IFDEF LOGGING}
Session.SystemLog('MPE ProcID: ' + strI2S(ProcID));
{$ENDIF}
Case ProcID of
0 : Session.io.OutFull(Param[1].S);
1 : Session.io.OutFullLn(Param[1].S);
2 : Session.io.AnsiClear;
3 : Session.io.AnsiClrEOL;
4 : Session.io.AnsiGotoXY(Param[1].B, Param[2].B);
5 : Begin
TempByte := Screen.CursorX;
Store(TempByte, 1);
End;
6 : Begin
TempByte := Screen.CursorY;
Store(TempByte, 1);
End;
7 : Begin
TempStr := Session.io.GetKey;
Store(TempStr, 256);
End;
8 : Begin
Session.io.BufFlush;
WaitMS(Param[1].L);
End;
9 : Begin
TempLong := Random(Param[1].L);
Store (TempLong, 4);
End;
10 : Begin
TempChar := Chr(Param[1].B);
Store (TempChar, 1);
End;
11 : Begin
TempByte := Ord(Param[1].S[1]);
Store (TempByte, 1);
End;
12 : Begin
TempStr := Copy(Param[1].S, Param[2].L, Param[3].L);
Store (TempStr, 256);
End;
13 : Delete(String(Pointer(Param[1].vData)^), Param[2].L, Param[3].L);
14 : Insert(Param[1].S, String(Pointer(Param[2].vData)^), Param[3].L);
15 : Begin
TempLong := Length(Param[1].S);
Store (TempLong, 4);
End;
16 : Begin
TempBool := Odd(Param[1].L);
Store (TempBool, 1);
End;
17 : Begin
TempLong := Pos(Param[1].S, Param[2].S);
Store (TempLong, 4);
End;
18 : Begin
{$IFDEF UNIX}
TempBool := Input.KeyPressed;
{$ELSE}
TempBool := Input.KeyPressed OR Session.Client.DataWaiting;
{$ENDIF}
Store (TempBool, 1);
Session.io.BufFlush;
End;
19 : Begin
TempStr := strPadR(Param[1].S, Param[2].B, Param[3].S[1]);
Store (TempStr, 256);
End;
20 : Begin
TempStr := strPadL(Param[1].S, Param[2].B, Param[3].S[1]);
Store (TempStr, 256);
End;
21 : Begin
TempStr := strPadC(Param[1].S, Param[2].B, Param[3].S[1]);
Store (TempStr, 256);
End;
22 : Begin
TempStr := strUpper(Param[1].S);
Store (TempStr, 256);
End;
23 : Begin
TempStr := strLower(Param[1].S);
Store (TempStr, 256);
End;
24 : Begin
TempStr := strRep(Param[1].S[1], Param[2].B);
Store (TempStr, 256);
End;
25 : Begin
TempStr := strComma(Param[1].L);
Store (TempStr, 256);
End;
26 : Begin
TempStr := strI2S(Param[1].L);
Store (TempStr, 256);
End;
27 : Begin
TempLong := strS2I(Param[1].S);
Store (TempLong, 4);
End;
28 : Begin
TempStr := strI2H(Param[1].L);
Store (TempStr, 256);
End;
29 : Begin
TempStr := strWordGet(Param[1].B, Param[2].S, Param[3].S[1]);
Store (TempStr, 256);
End;
30 : Begin
TempByte := strWordPos(Param[1].B, Param[2].S, Param[3].S[1]);
Store (TempByte, 1);
End;
31 : Begin
TempByte := strWordCount(Param[1].S, Param[2].S[1]);
Store (TempByte, 1);
End;
32 : Begin
TempStr := strStripL(Param[1].S, Param[2].S[1]);
Store (TempStr, 256);
End;
33 : Begin
TempStr := strStripR(Param[1].S, Param[2].S[1]);
Store (TempStr, 256);
End;
34 : Begin
TempStr := strStripB(Param[1].S, Param[2].S[1]);
Store (TempStr, 256);
End;
35 : Begin
TempStr := strStripLow(Param[1].S);
Store (TempStr, 256);
End;
36 : Begin
TempStr := strStripMCI(Param[1].S);
Store (TempStr, 256);
End;
37 : Begin
TempByte := strMCILen(Param[1].S);
Store (TempByte, 1);
End;
38 : Begin
TempStr := strInitials(Param[1].S);
Store (TempStr, 256);
End;
39 : Begin
TempByte := strWrap(String(Pointer(Param[1].vData)^), String(Pointer(Param[2].vData)^), Param[3].B);
Store (TempByte, 1);
End;
40 : Begin
TempStr := strReplace(Param[1].S, Param[2].S, Param[3].S);
Store (TempStr, 256);
End;
41 : Begin
TempStr := GetEnv(Param[1].S);
Store (TempStr, 256);
End;
42 : Begin
TempBool := FileExist(Param[1].S);
Store (TempBool, 1);
End;
43 : FileErase(Param[1].S);
44 : Begin
TempBool := FileDirExists(Param[1].S);
Store (TempBool, 1);
End;
45 : Begin
TempLong := TimerMinutes;
Store (TempLong, 4);
End;
46 : Begin
TempLong := TimerSeconds;
Store (TempLong, 4);
End;
47 : Begin
TempLong := CurDateDos;
Store (TempLong, 4);
End;
48 : Begin
TempLong := CurDateJulian;
Store (TempLong, 4);
End;
49 : Begin
TempStr := DateDos2Str(Param[1].L, Param[2].B);
Store (TempStr, 256);
End;
50 : Begin
TempStr := DateJulian2Str(Param[1].L, Param[2].B);
Store (TempStr, 256);
End;
51 : Begin
TempLong := DateStr2Dos(Param[1].S);
Store (TempLong, 4);
End;
52 : Begin
TempLong := DateStr2Julian(Param[1].S);
Store (TempLong, 4);
End;
53 : DateG2J(Param[1].L, Param[2].L, Param[3].L, LongInt(VarData[Param[4].vID]^.Data));
54 : DateJ2G(Param[1].L, SmallInt(Pointer(Param[2].vData)^), SmallInt(Pointer(Param[3].vData)^), SmallInt(Pointer(Param[4].vData)^));
55 : Begin
TempBool := DateValid(Param[1].S);
Store (TempBool, 1);
End;
56 : Begin
TempStr := TimeDos2Str(Param[1].L, Param[2].O);
Store (TempStr, 256);
End;
57 : Begin
TempByte := DayOfWeek;
Store (TempByte, 1);
End;
58 : Begin
TempLong := DaysAgo(Param[1].L);
Store (TempLong, 4);
End;
59 : Begin
TempStr := JustFile(Param[1].S);
Store (TempStr, 256);
End;
60 : Begin
TempStr := JustFileName(Param[1].S);
Store (TempStr, 256);
End;
61 : Begin
TempStr := JustFileExt(Param[1].S);
Store (TempStr, 256);
End;
62 : Begin
Assign (File(Pointer(Param[1].vData)^), Param[2].S);
FileMode := Param[3].L;
End;
63 : Begin
Reset (File(Pointer(Param[1].vData)^), 1);
IoError := IoResult;
End;
64 : Begin
ReWrite (File(Pointer(Param[1].vData)^), 1);
IoError := IoResult;
End;
65 : Begin
Close (File(Pointer(Param[1].vData)^));
IoError := IoResult;
End;
66 : Begin
Seek (File(Pointer(Param[1].vData)^), Param[2].L);
IoError := IoResult;
End;
67 : Begin
TempBool := Eof(File(Pointer(Param[1].vData)^));
IoError := IoResult;
Store (TempBool, 1);
End;
68 : Begin
TempLong := FileSize(File(Pointer(Param[1].vData)^));
IoError := IoResult;
Store (TempLong, 4);
End;
69 : Begin
TempLong := FilePos(File(Pointer(Param[1].vData)^));
IoError := IoResult;
Store (TempLong, 4);
End;
70 : Begin
BlockRead (File(Pointer(Param[1].vData)^), Param[2].vData^, Param[3].W);
IoError := IoResult;
End;
71 : Begin
BlockWrite (File(Pointer(Param[1].vData)^), Param[2].vData^, Param[3].W);
IoError := IoResult;
End;
72 : FileReadLine (File(Pointer(Param[1].vData)^), String(Pointer(Param[2].vData)^));
73 : FileWriteLine (File(Pointer(Param[1].vData)^), Param[2].S);
74 : Begin
TempChar := PathChar;
Store (TempChar, 1);
End;
75 : Begin
TempBool := BitCheck(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^);
Store (TempBool, 1);
End;
76 : BitToggle(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^);
77 : BitSet(Param[1].B, Param[2].vSize, VarData[Param[2].vID]^.Data^, Param[3].O);
78 : Begin
FindFirst(Param[1].S, Param[2].W, DirInfo);
Move (DirInfo.Name, VarData[IdxVarDir ]^.Data^, SizeOf(DirInfo.Name));
Move (DirInfo.Size, VarData[IdxVarDir + 1]^.Data^, SizeOf(DirInfo.Size));
Move (DirInfo.Time, VarData[IdxVarDir + 2]^.Data^, SizeOf(DirInfo.Time));
Move (DirInfo.Attr, VarData[IdxVarDir + 3]^.Data^, SizeOf(DirInfo.Attr));
End;
79 : Begin
FindNext(DirInfo);
Move (DirInfo.Name, VarData[IdxVarDir ]^.Data^, SizeOf(DirInfo.Name));
Move (DirInfo.Size, VarData[IdxVarDir + 1]^.Data^, SizeOf(DirInfo.Size));
Move (DirInfo.Time, VarData[IdxVarDir + 2]^.Data^, SizeOf(DirInfo.Time));
Move (DirInfo.Attr, VarData[IdxVarDir + 3]^.Data^, SizeOf(DirInfo.Attr));
End;
80 : FindClose(DirInfo);
81 : Begin
TempStr := JustPath(Param[1].S);
Store (TempStr, 256);
End;
82 : Randomize;
83 : Begin
TempByte := strWordCount(ParamsStr, ' ');
Store (TempByte, 1);
End;
84 : Begin
If Param[1].B = 0 Then
TempStr := MPEName
Else
TempStr := strWordGet(Param[1].B, ParamsStr, ' ');
Store (TempStr, 256);
End;
85 : Begin
TempByte := Screen.TextAttr;
Store (TempByte, 1);
End;
86 : Session.io.AnsiColor(Param[1].B);
87 : Begin
TempStr := DirSlash(Param[1].S);
Store (TempStr, 256);
End;
88 : Begin
TempStr := strStripPipe(Param[1].S);
Store (TempStr, 256);
End;
500 : Begin
TempStr := Session.io.GetInput(Param[1].B, Param[2].B, Param[3].B, Param[4].S);
Store (TempStr, 256);
Session.io.AllowArrow := True;
End;
501 : Begin
TempBool := GetUserRecord(Param[1].L);
Store (TempBool, 1);
End;
502 : Begin
TempChar := Session.io.OneKey(Param[1].S, Param[1].O);
Store (TempChar, 1);
End;
503 : GetUserVars(Session.User.ThisUser);
504 : Begin
TempBool := Session.io.GetYN(Param[1].S, True);
Store (TempBool, 1);
End;
505 : Begin
TempBool := Session.io.GetYN(Param[1].S, False);
Store (TempBool, 1);
End;
506 : Begin
Session.io.OutFile(Param[1].S, True, 0);
TempBool := Not Session.io.NoFile;
Store (TempBool, 1);
End;
507 : Begin
TempBool := CopyFile(Param[1].S, Param[2].S);
Store (TempBool, 1);
End;
508 : Begin
ReloadMenu := Session.Menu.ExecuteCommand(Param[1].S, Param[2].S);
Session.io.AllowArrow := True;
End;
509 : Begin
Session.io.InMacroStr := Param[1].S;
Session.io.InMacroPos := 1;
Session.io.InMacro := Session.io.InMacroStr <> '';
End;
510 : Begin
TempBool := Session.User.Access(Param[1].S);
Store (TempBool, 1);
End;
511 : Upgrade_User_Level(True, Session.User.ThisUser, Param[1].I);
512 : Session.SetTimeLeft(Param[1].I);
513 : Halt(0);
514 : Begin
TempBool := GetMBaseRecord(Param[1].L);
Store (TempBool, 1);
End;
515 : Begin
TempStr := Session.GetPrompt(Param[1].L);
Store (TempStr, 256);
End;
516 : Begin
TempBool := GetMGroupRecord(Param[1].L);
Store (TempBool, 1);
End;
517 : Session.io.PurgeInputBuffer;
518 : Begin
TempBool := GetFBaseRecord(Param[1].L);
Store (TempBool, 1);
End;
519 : Begin
TempBool := GetFGroupRecord(Param[1].L);
Store (TempBool, 1);
End;
520 : Session.SystemLog(Param[1].S);
521 : Session.io.AnsiMoveX(Param[1].B);
522 : Session.io.AnsiMoveY(Param[1].B);
523 : Session.io.OutPipe(Param[1].S);
524 : Session.io.OutPipeLn(Param[1].S);
525 : Session.io.OutRaw(Param[1].S);
526 : Session.io.OutRawLn(Param[1].S);
527 : Begin
TempStr := '';
If Session.io.ParseMCI(False, Param[1].S) Then
TempStr := Session.io.LastMCIValue;
Store (TempStr, 256);
End;
528 : Begin
TempInt := Session.TimeLeft;
Store (TempInt, 2);
End;
529 : If Param[1].B < 10 Then Begin
Move (Session.io.ScreenInfo[Param[1].B].X, Param[2].vData^, 1);
Move (Session.io.ScreenInfo[Param[1].B].Y, Param[3].vData^, 1);
Move (Session.io.ScreenInfo[Param[1].B].A, Param[4].vData^, 1);
End;
530 : If Param[1].B < FileSize(Session.PromptFile) Then Begin
Seek (Session.PromptFile, Param[1].B);
Write (Session.PromptFile, Param[2].S);
End;
531 : Begin
TempChar := Session.io.MorePrompt;
Store (TempChar, 1);
End;
532 : Session.io.PauseScreen;
533 : If Param[1].B <= MaxPromptInfo Then Session.io.PromptInfo[Param[1].B] := Param[2].S;
534 : Session.io.BufFlush;
535 : Begin
TempStr := Session.io.StrMci(Param[1].S);
Store (TempStr, 256);
End;
536 : Begin
TempChar := #0;
If (Param[1].B < 81) and (Param[2].B < 26) Then
TempChar := Screen.Buffer[Param[2].B][Param[1].B].UnicodeChar;
Store (TempChar, 1);
End;
537 : Begin
TempByte := 0;
If (Param[1].B < 81) and (Param[2].B < 26) Then
TempByte := Screen.Buffer[Param[2].B][Param[1].B].Attributes;
Store (TempByte, 1);
End;
End;
End;
Procedure TInterpEngine.SkipBlock;
begin
NextChar;
NextWord;
MoveToPos (CurFilePos + W);
end;
Procedure TInterpEngine.DefineProcedure;
Var
Count : Word;
VarChar : Char;
Params : Word;
NumVars : Word;
Begin
NextWord; { procedure var id }
If FindVariable(W) > 0 Then Begin /// ????????????????????
Error (mpxMultiInit, '');
Exit;
End;
Inc (CurVarNum);
New (VarData[CurVarNum]);
With VarData[CurVarNum]^ Do Begin
VarID := W;
vType := iNone;
NumParams := 0;
ProcPos := 0;
VarSize := 0;
Datasize := 0;
ArrPos := 0;
Kill := False;
Data := NIL;
End;
NextChar;
Params := 0;
While (ErrNum = 0) And (Not (Ch in [Char(opProcType), Char(opBlockOpen)])) Do Begin
VarChar := Ch;
NextWord;
NumVars := W;
For Count := 1 To NumVars Do Begin
Inc(Params);
VarData[CurVarNum]^.Params[Params] := VarChar;
NextWord;
VarData[CurVarNum]^.pID[Params] := W;
End;
NextChar;
End;
If Ch = Char(opProcType) Then Begin
NextChar;
VarData[CurVarNum]^.vType := cVarType(Ch);
VarData[CurVarNum]^.VarSize := xVarSize(VarData[CurVarNum]^.vType);
End Else
PrevChar;
VarData[CurVarNum]^.NumParams := Params;
VarData[CurVarNum]^.ProcPos := CurFilePos;
SkipBlock;
End;
Procedure TInterpEngine.StatementForLoop;
Var
VarNum : Word;
VarArray : TArrayInfo;
LoopStart : Real;
LoopEnd : Real;
Count : Real;
CountTo : Boolean;
SavedPos : LongInt;
Begin
NextWord;
VarNum := FindVariable(W);
CheckArray (VarNum, VarArray);
LoopStart := EvaluateNumber;
NextChar;
CountTo := Ch = Char(opTo);
LoopEnd := EvaluateNumber;
Count := LoopStart;
SavedPos := CurFilePos;
If (CountTo And (LoopStart > LoopEnd)) Or ((Not CountTo) And (LoopStart < LoopEnd)) Then
SkipBlock
Else
If CountTo Then
While (Count <= LoopEnd) And Not Done Do Begin
SetNumber(VarNum, Count, VarArray);
MoveToPos(SavedPos);
If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Break;
Count := GetNumber(VarNum, VarArray) + 1;
End
Else
While (Count >= LoopEnd) And Not Done Do Begin
SetNumber(VarNum, Count, VarArray);
MoveToPos(SavedPos);
If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Break;
Count := GetNumber(VarNum, VarArray) - 1;
End;
End;
Procedure TInterpEngine.StatementWhileDo;
Var
IsTrue : Boolean;
StartPos : LongInt;
begin
StartPos := CurFilePos;
IsTrue := True;
While (ErrNum = 0) And IsTrue And Not Done Do Begin
IsTrue := EvaluateBoolean;
If IsTrue Then Begin
If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Begin
MoveToPos (StartPos);
EvaluateBoolean;
SkipBlock;
Break;
End Else
MoveToPos (StartPos);
End Else
SkipBlock;
End;
End;
Procedure TInterpEngine.StatementRepeatUntil;
Var
StartPos: LongInt;
Begin
StartPos := CurFilePos;
Repeat
MoveToPos (StartPos);
If ExecuteBlock (CurVarNum, CurRecNum) = 1 Then Begin
EvaluateBoolean;
Break;
End;
Until (ErrNum <> 0) or (EvaluateBoolean) or Done;
End;
Function TInterpEngine.StatementCase : Byte;
Var
StartPos : LongInt;
EndPos : LongInt;
TempStr : String;
TempBol : Boolean;
TempNum : Real;
Found : Boolean;
VarType : TIdentTypes;
Numbers : Array[1..mplMaxCaseNums] of Record
Num : Real;
Range : Boolean;
End;
NumberPos : Word;
Count : Word;
Str : String;
Begin
NextWord; // statement size
Result := 0;
StartPos := CurFilePos;
EndPos := W;
Found := False;
NumberPos := 0;
NextChar;
VarType := TIdentTypes(Byte(Ch));
Case VarType of
iChar,
iString : TempStr := EvaluateString;
iBool : TempBol := EvaluateBoolean;
Else
TempNum := EvaluateNumber;
End;
Repeat
Case VarType of
iChar,
iString : Repeat
Str := EvaluateString;
Found := Found or (TempStr = Str);
NextChar;
If Ch <> Char(opParamSep) Then Begin
PrevChar;
Break;
End;
Until ErrNum <> 0;
iBool : Found := EvaluateBoolean = TempBol;
Else
Repeat
Inc (NumberPos);
Numbers[NumberPos].Num := EvaluateNumber;
NextChar;
If Ch = Char(opParamSep) Then
Numbers[NumberPos].Range := False
Else
If Ch = Char(opNumRange) Then
Numbers[NumberPos].Range := True
Else Begin
Numbers[NumberPos].Range := False;
PrevChar;
Break;
End;
Until ErrNum <> 0;
Count := 1;
Repeat
If Numbers[Count].Range Then
Found := (TempNum >= Numbers[Count].Num) and (TempNum <= Numbers[Count + 1].Num)
Else
Found := TempNum = Numbers[Count].Num;
Inc (Count);
Until Found or (Count > NumberPos);
End;
If Found Then Begin
Result := ExecuteBlock (CurVarNum, CurRecNum);
MoveToPos (StartPos + EndPos);
Exit;
End Else
SkipBlock;
NextChar;
If Ch = Char(opElse) Then Begin
// we probably want to skip the open block here in compiler
Result := ExecuteBlock(CurVarNum, CurRecNum);
Break;
End Else
If Ch = Char(opBlockClose) Then
Break
Else
PrevChar;
Until (ErrNum > 0) or Done;
End;
Function TInterpEngine.StatementIfThenElse : Byte;
Var
Ok : Boolean;
Begin
Result := 0;
Ok := EvaluateBoolean;
//tbbscore(owner).systemlog('if statement');
//if ok then tbbscore(owner).systemlog('is true') else tbbscore(owner).systemlog('is false');
If Ok Then
Result := ExecuteBlock(CurVarNum, CurRecNum)
Else
SkipBlock;
NextChar;
If Ch = Char(opElse) Then Begin
If Not Ok Then
Result := ExecuteBlock(CurVarNum, CurRecNum)
Else
SkipBlock;
End Else
PrevChar;
End;
Procedure TInterpEngine.DefineRecord;
Var
Count : LongInt;
RecSize : LongInt;
Begin
NextWord;
Inc (CurRecNum);
New (RecData[CurRecNum]);
RecData[CurRecNum]^.RecStart := CurVarNum + 1;
RecData[CurRecNum]^.NumFields := W;
// DefineVariable; // base record variable
RecSize := 0;
For Count := 1 to RecData[CurRecNum]^.NumFields Do Begin
NextChar;
Inc (RecSize, DefineVariable);
End;
// now we need to build something to create a record block of data
// and to dispose it based on the variables
// this method will not work for records in records or arrays of records
// and really should be re-done. the problem is, the evaluators will
// take a lot of changes to suport iRecord correctly.
End;
Function TInterpEngine.ExecuteBlock (StartVar, StartRec: Word) : Byte;
Var
Count : Word;
BlockStart : LongInt;
BlockSize : Word;
Begin
Result := 0;
NextChar; // block begin character... can we ignore it? at least for case_else
NextWord; // or just have case else ignore the begin at the compiler level
// but still output the begin
BlockStart := CurFilePos;
BlockSize := W;
Repeat
NextChar;
Case TTokenOpsRec(Byte(Ch)) of
{0} opBlockOpen : Begin
PrevChar;
Self.ExecuteBlock(CurVarNum, CurRecNum);
End;
{1} opBlockClose : Break;
{2} opVarDeclare : DefineVariable;
{12} opSetVar : Begin
NextWord;
SetVariable(FindVariable(W));
End;
{18} opProcDef : DefineProcedure;
{19} opProcExec : ExecuteProcedure(NIL);
{21} opFor : StatementForLoop;
{34} opIf : Begin
Result := StatementIfThenElse;
If Result > 0 Then Begin
MoveToPos(BlockStart + BlockSize);
Break;
End;
End;
{36} opWhile : StatementWhileDo;
{39} opRepeat : StatementRepeatUntil;
{47} opGoto : Begin
NextWord;
MoveToPos(W);
End;
{49} opHalt : Done := True;
{50} opCase : Begin
Result := StatementCase;
If Result > 0 Then Begin
MoveToPos(BlockStart + BlockSize);
Break;
End;
End;
{52} opTypeRec : DefineRecord;
{53} opBreak : Begin
MoveToPos (BlockStart + BlockSize);
Result := 1;
Break;
End;
{54} opContinue : Begin
MoveToPos (BlockStart + BlockSize);
Result := 2;
Break;
End;
{55} opUses : Begin
Repeat
NextWord;
InitProcedures (Owner, Self, VarData, CurVarNum, CurVarID, W);
NextChar;
If Ch <> Char(opParamSep) Then Begin
PrevChar;
Break;
End;
Until ErrNum <> 0;
End;
{56} opExit : Begin
Done := True;
ExitProc := True;
End;
Else
Error (mpxUnknownOp, strI2S(Ord(Ch)));
End;
Until (ErrNum <> 0) or Done or DataFile^.EOF;
{$IFDEF LOGGING}
Session.SystemLog('MPE: Kill Block Vars');
{$ENDIF}
For Count := CurVarNum DownTo StartVar + 1 Do Begin
If (VarData[Count]^.Kill) And (VarData[Count]^.Data <> NIL) Then begin
FreeMem(VarData[Count]^.Data, VarData[Count]^.DataSize);
end;
Dispose (VarData[Count]);
End;
{$IFDEF LOGGING}
Session.SystemLog('MPE: Kill Block Done');
{$ENDIF}
For Count := CurRecNum DownTo StartRec + 1 Do
Dispose(RecData[Count]);
// dispose record data block? or just calc it whenever there is an
// assignment or filewrite, etc?
CurVarNum := StartVar;
CurRecNum := StartRec;
End;
Function TInterpEngine.Execute (FN: String) : Byte;
// 0 = not found 1 = ok 2 = goto new menu
Var
VerStr : String;
Res : LongInt;
Begin
Result := 0;
CurVarNum := 0;
CurVarID := 0;
CurRecNum := 0;
ReloadMenu := False;
Done := False;
ExitProc := False;
SavedMCI := Session.io.AllowMCI;
SavedGroup := Session.User.IgnoreGroup;
SavedArrow := Session.io.AllowArrow;
DataFile := New(PCharFile, Init(mplExecuteBuffer));
Session.io.AllowArrow := True;
If strWordCount(FN, ' ') > 1 Then Begin
ParamsStr := Copy(FN, strWordPos(2, FN, ' '), Length(FN));
FN := strWordGet(1, FN, ' ');
End Else
ParamsStr := '';
If Pos('.', FN) = 0 Then FN := FN + mplExtExecute;
If Pos(PathChar, FN) = 0 Then
FN := Config.ScriptPath + FN;
MPEName := FN;
If Not DataFile^.Open(FN) Then Begin
Dispose(DataFile, Done);
Exit;
End;
Result := 1;
If DataFile^.FileSize < mplVerLength Then Begin
DataFile^.Close;
Error (mpxInvalidFile, FN);
Dispose (DataFile, Done);
Exit;
End;
DataFile^.BlockRead (VerStr[1], mplVerLength, Res);
VerStr[0] := Chr(mplVerLength);
If VerStr <> mplVersion Then Begin
DataFile^.Close;
Error (mpxVerMismatch, VerStr);
Dispose (DataFile, Done);
Exit;
End;
InitProcedures (Owner, Self, VarData, CurVarNum, CurVarID, 0);
ExecuteBlock (CurVarNum, CurRecNum);
DataFile^.Close;
Dispose(DataFile, Done);
Session.io.AllowMCI := SavedMCI;
Session.User.IgnoreGroup := SavedGroup;
Session.io.AllowArrow := SavedArrow;
Result := Ord(ReloadMenu) + 1;
End;
Function ExecuteMPL (Owner: Pointer; Str: String) : Byte;
Var
Script : TInterpEngine;
Begin
Script := TInterpEngine.Create(Owner);
Result := Script.Execute(Str);
If Script.ErrNum > 0 Then
Session.io.OutFullLn ('|CR|12MPX ERROR: ' + Script.GetErrorMsg);
Script.Free;
End;
End.