Skip to content

Add a 'raise' statement and the ParamCount/ParamStr builtins #310

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
TetzkatLipHoka wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add a 'raise' statement and the ParamCount/ParamStr builtins #310

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
109 changes: 109 additions & 0 deletions Source/uPSCompiler.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10971,6 +10971,107 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
Result := True;
end; {ProcessIdentifier}

function ProcessRaise: Boolean;
{ 'raise;' re-raises the current exception (compiled as a call to
RaiseLastException); 'raise <class>.Create(<message>);' compiles to
RaiseException(erCustomError, <message>). The class name is parsed but
not evaluated - scripts have no exception objects; the strict grammar
keeps the parser deterministic. }
var
L: Cardinal;
Decl: TPSParametersDecl;
Call: TPSValueProcNo;
Msg: TPSValue;
ExData: TPSValueData;
Con: TPSConstant;
begin
Result := False;
Debug_WriteLine(BlockInfo);
FParser.Next; // skip RAISE
if (FParser.CurrTokenId = CSTI_Semicolon) or (FParser.CurrTokenId = CSTII_End) or
(FParser.CurrTokenId = CSTII_Else) or (FParser.CurrTokenId = CSTII_Except) or
(FParser.CurrTokenId = CSTII_Finally) or (FParser.CurrTokenId = CSTII_until) then
begin // bare 'raise': re-raise the current exception
L := FindProc('RaiseLastException');
if L = InvalidVal then
begin
MakeError('', ecUnknownIdentifier, 'RaiseLastException');
exit;
end;
Call := TPSValueProcNo.Create;
Call.SetParserPos(FParser);
Call.ProcNo := L;
Call.ResultType := nil;
Call.Parameters := TPSParameters.Create;
Result := _ProcessFunction(Call, nil);
Call.Free;
exit;
end;
if FParser.CurrTokenId <> CSTI_Identifier then
begin
MakeError('', ecIdentifierExpected, '');
exit;
end;
FParser.Next;
if FParser.CurrTokenId <> CSTI_Period then
begin
MakeError('', ecPeriodExpected, '');
exit;
end;
FParser.Next;
if (FParser.CurrTokenId <> CSTI_Identifier) or (FParser.GetToken <> 'CREATE') then
begin
MakeError('', ecIdentifierExpected, FParser.OriginalToken);
exit;
end;
FParser.Next;
if FParser.CurrTokenId <> CSTI_OpenRound then
begin
MakeError('', ecOpenRoundExpected, '');
exit;
end;
FParser.Next;
L := FindProc('RaiseException');
Con := GetConstant('erCustomError');
if (L = InvalidVal) or (Con = nil) then
begin
MakeError('', ecUnknownIdentifier, 'RaiseException');
exit;
end;
Msg := Calc(CSTI_CloseRound);
if Msg = nil then
exit;
if FParser.CurrTokenId <> CSTI_CloseRound then
begin
MakeError('', ecCloseRoundExpected, '');
Msg.Free;
exit;
end;
FParser.Next;
if TPSProcedure(FProcs[L]).ClassType = TPSInternalProcedure then
Decl := TPSInternalProcedure(FProcs[L]).Decl
else
Decl := TPSExternalProcedure(FProcs[L]).RegProc.Decl;
ExData := TPSValueData.Create;
ExData.SetParserPos(FParser);
ExData.Data := NewVariant(at2ut(Con.Value.FType));
ExData.Data.tu32 := Con.Value.tu32;
Call := TPSValueProcNo.Create;
Call.SetParserPos(FParser);
Call.ProcNo := L;
Call.ResultType := Decl.Result;
Call.Parameters := TPSParameters.Create;
Call.Parameters.Add.Val := ExData;
Call.Parameters.Add.Val := Msg;
if not ValidateParameters(BlockInfo, Call.Parameters, Decl) then
begin
Call.Free;
exit;
end;
Result := _ProcessFunction(Call, nil);
Call.Free;
end; {ProcessRaise}

function ProcessCase: Boolean;
var
V1, V2, TempRec, Val, CalcItem: TPSValue;
Expand Down Expand Up @@ -11677,6 +11778,12 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
FParser.Next;
if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
break;
end else if FParser.GetToken = 'RAISE' then
begin
if not ProcessRaise then
exit;
if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
break;
end else
if not ProcessIdentifier then
exit;
Expand Down Expand Up @@ -13952,6 +14059,8 @@ procedure TPSPascalCompiler.DefineStandardProcedures;
AddFunction('function ExceptionProc: Cardinal;');
AddFunction('function ExceptionPos: Cardinal;');
AddFunction('function ExceptionToString(er: TIFException; Param: string): string;');
AddFunction('function ParamCount: Integer;');
AddFunction('function ParamStr(Index: Integer): string;');
{$IFNDEF PS_NOINT64}
AddFunction('function StrToInt64(S: string): Int64;');
AddFunction('function Int64ToStr(I: Int64): string;');
Expand Down
4 changes: 4 additions & 0 deletions Source/uPSRuntime.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9756,6 +9756,8 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack
47: Stack.SetUInt64(-1, StrToUInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetUInt64(-3))); // StrToUInt64Def
{$ENDIF}
48: Stack.SetAnsiString(-1, tbtstring(SysUtils.UIntToStr({$IFNDEF PS_NOINT64}Stack.GetUInt64(-2){$ELSE}Stack.GetUInt(-2){$ENDIF}))); // UIntToStr
49: Stack.SetInt(-1, ParamCount); // ParamCount
50: {$IFNDEF PS_NOWIDESTRING}Stack.SetUnicodeString(-1, tbtunicodestring(ParamStr(Stack.GetInt(-2)))){$ELSE}Stack.SetAnsiString(-1, tbtstring(ParamStr(Stack.GetInt(-2)))){$ENDIF}; // ParamStr
42: // sizeof
begin
temp := NewTPSVariantIFC(Stack[Stack.Count -2], False);
Expand Down Expand Up @@ -10129,6 +10131,8 @@ procedure TPSExec.RegisterStandardProcs;

RegisterFunctionName('IntToStr', DefProc, Pointer(0), nil);
RegisterFunctionName('UIntToStr', DefProc, Pointer(48), nil);
RegisterFunctionName('ParamCount', DefProc, Pointer(49), nil);
RegisterFunctionName('ParamStr', DefProc, Pointer(50), nil);
RegisterFunctionName('StrToInt', DefProc, Pointer(1), nil);
RegisterFunctionName('StrToIntDef', DefProc, Pointer(2), nil);
RegisterFunctionName('Pos', DefProc, Pointer(3), nil);
Expand Down