paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-02-04 06:54:52 +01:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: method modifier message integer/string

Browse Source 
git-svn-id: trunk@41583 -
This commit is contained in:
Mattias Gaertner 2019-03-03 23:30:13 +00:00
parent cbdd7e892f
commit e3cd320580
5 changed files with 228 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -187,6 +187,7 @@ const
nUnknownCustomAttributeX = 3121;
nAttributeIgnoredBecauseAbstractX = 3122;
nCreatingAnInstanceOfAbstractClassY = 3123;
nIllegalExpressionAfterX = 3124;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -321,6 +322,7 @@ resourcestring
sUnknownCustomAttributeX = 'Unknown custom attribute "%s"';
sAttributeIgnoredBecauseAbstractX = 'attribute ignored because abstract %s';
sCreatingAnInstanceOfAbstractClassY = 'Creating an instance of abstract class "%s"';
sIllegalExpressionAfterX = 'illegal expression after %s';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

189
packages/pastojs/src/fppas2js.pp
View File

@ -521,6 +521,7 @@ const
nJSNewNotSupported = 4026;
nHelperClassMethodForExtClassMustBeStatic = 4027;
nBitWiseOperationIs32Bit = 4028;
nDuplicateMessageIdXAtY = 4029;
// resourcestring patterns of messages
resourcestring
sPasElementNotSupported = 'Pascal element not supported: %s';
@ -551,6 +552,7 @@ resourcestring
sJSNewNotSupported = 'Pascal class does not support the "new" constructor';
sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static';
sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit';
sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
const
ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@ -559,6 +561,7 @@ const
type
TPas2JSBuiltInName = (
// functions
pbifnArray_Concat,
pbifnArray_ConcatN,
pbifnArray_Copy,
@ -660,12 +663,15 @@ type
pbifnSpaceLeft,
pbifnStringSetLength,
pbifnUnitInit,
// variables
pbivnExceptObject,
pbivnIntfExprRefs,
pbivnIntfGUID,
pbivnIntfKind,
pbivnIntfMaps,
pbivnImplementation,
pbivnMessageInt,
pbivnMessageStr,
pbivnLoop,
pbivnLoopEnd,
pbivnLoopIn,
@ -699,6 +705,7 @@ type
pbivnSelf,
pbivnTObjectDestroy,
pbivnWith,
// types
pbitnAnonymousPostfix,
pbitnIntDouble,
pbitnTI,
@ -828,6 +835,8 @@ const
'$kind',
'$intfmaps',
'$impl',
'$msgint', // pbivnMessageInt
'$msgstr', // pbivnMessageStr
'$l',
'$end',
'$in',
@ -1108,12 +1117,16 @@ type
JS: string; // Option coStoreProcJS
end;
TMessageIdToProc_List = TStringList;
{ TPas2JSClassScope }
TPas2JSClassScope = class(TPasClassScope)
public
NewInstanceFunction: TPasClassFunction;
GUID: string;
MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // temporary lists, not stored by filer!
destructor Destroy; override;
end;
{ TPas2JSProcedureScope }
@ -1393,6 +1406,8 @@ type
function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
function IsTGUID(TypeEl: TPasRecordType): boolean; override;
function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
procedure AddMessageStr(var MsgToProc: TMessageIdToProc_List; const S: string; Proc: TPasProcedure);
procedure AddMessageIdToClassScope(Proc: TPasProcedure); virtual;
// CustomData
function GetElementData(El: TPasElementBase;
DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
@ -1813,6 +1828,8 @@ type
Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements;
FuncContext: TFunctionContext);
Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement);
Procedure AddClassMessageIds(El: TPasClassType; Src: TJSSourceElements;
FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName);
// misc
Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
AContext: TConvertContext): TJSElement; virtual;
@ -2139,6 +2156,15 @@ begin
Result:='['+Result+']';
end;
{ TPas2JSClassScope }
destructor TPas2JSClassScope.Destroy;
begin
FreeAndNil(MsgIntToProc);
FreeAndNil(MsgStrToProc);
inherited Destroy;
end;
{ TRootContext }
procedure TRootContext.AddGlobalClassMethod(p: TPasProcedure);
@ -3807,7 +3833,7 @@ begin
for pm in Proc.Modifiers do
if (not (pm in [pmVirtual, pmAbstract, pmOverride,
pmOverload, pmReintroduce,
pmOverload, pmMessage, pmReintroduce,
pmInline, pmAssembler, pmPublic,
pmExternal, pmForward])) then
RaiseNotYetImplemented(20170208142159,El,'modifier '+ModifierNames[pm]);
@ -3823,6 +3849,22 @@ begin
RaiseMsg(20170324150417,nPasElementNotSupported,sPasElementNotSupported,
['public name'],Proc.PublicName);
// modifier dispid
if Proc.DispIDExpr<>nil then
RaiseMsg(20190303225224,nPasElementNotSupported,sPasElementNotSupported,
['dispid'],Proc.DispIDExpr);
// modifier message
if Proc.MessageExpr<>nil then
begin
if (not (Proc.Parent is TPasClassType))
or (TPasClassType(Proc.Parent).ObjKind<>okClass) then
RaiseMsg(20190303231445,nInvalidXModifierY,sInvalidXModifierY,['message','at non class method'],Proc.MessageExpr);
if TPasClassType(Proc.Parent).IsExternal then
RaiseMsg(20190304002235,nInvalidXModifierY,sInvalidXModifierY,['message','in external class'],Proc.MessageExpr);
AddMessageIdToClassScope(Proc);
end;
if Proc.Parent is TPasMembersType then
begin
// class/record member
@ -5261,21 +5303,22 @@ begin
if Expr=nil then
RaiseInternalError(20170215123600);
Value:=Eval(Expr,[refAutoConst],StoreCustomData);
try
case Value.Kind of
{$IFDEF FPC_HAS_CPSTRING}
revkString: Result:=ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr);
revkUnicodeString: Result:=UTF8Encode(TResEvalUTF16(Value).S);
{$ELSE}
revkUnicodeString: Result:=TResEvalUTF16(Value).S;
{$ENDIF}
else
str(Value.Kind,Result);
RaiseXExpectedButYFound(20170211221121,'string literal',Result,Expr);
if Value<>nil then
try
case Value.Kind of
{$IFDEF FPC_HAS_CPSTRING}
revkString: Result:=ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr);
revkUnicodeString: Result:=UTF8Encode(TResEvalUTF16(Value).S);
{$ELSE}
revkUnicodeString: Result:=TResEvalUTF16(Value).S;
{$ENDIF}
else
str(Value.Kind,Result);
RaiseXExpectedButYFound(20170211221121,'string literal',Result,Expr);
end;
finally
ReleaseEvalValue(Value);
end;
finally
ReleaseEvalValue(Value);
end;
if NotEmpty and (Result='') then
RaiseXExpectedButYFound(20170321085318,'string literal','empty',Expr);
@ -5375,6 +5418,55 @@ begin
end;
end;
procedure TPas2JSResolver.AddMessageStr(var MsgToProc: TMessageIdToProc_List;
const S: string; Proc: TPasProcedure);
var
i: Integer;
begin
if MsgToProc=nil then
MsgToProc:=TMessageIdToProc_List.Create
else
begin
// check duplicate
for i:=0 to MsgToProc.Count-1 do
if MsgToProc[i]=S then
RaiseMsg(20190303233647,nDuplicateMessageIdXAtY,sDuplicateMessageIdXAtY,
[S,GetElementSourcePosStr(TPasProcedure(MsgToProc.Objects[i]).MessageExpr)],Proc.MessageExpr);
end;
MsgToProc.AddObject(S,Proc);
end;
procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure);
var
AClass: TPasClassType;
ClassScope: TPas2JSClassScope;
Expr: TPasExpr;
Value: TResEvalValue;
begin
AClass:=TPasClassType(Proc.Parent);
ClassScope:=TPas2JSClassScope(AClass.CustomData);
Expr:=Proc.MessageExpr;
Value:=Eval(Expr,[refConst]);
if Value=nil then
RaiseMsg(20190303225651,nIllegalExpressionAfterX,sIllegalExpressionAfterX,['message modifier'],Expr);
try
case Value.Kind of
{$ifdef FPC_HAS_CPSTRING}
revkString:
AddMessageStr(ClassScope.MsgStrToProc,ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr),Proc);
{$ENDIF}
revkUnicodeString:
AddMessageStr(ClassScope.MsgStrToProc,String(TResEvalUTF16(Value).S),Proc);
revkInt:
AddMessageStr(ClassScope.MsgIntToProc,IntToStr(TResEvalInt(Value).Int),Proc);
else
RaiseXExpectedButYFound(20190303225849,'integer constant',Value.AsString,Expr);
end;
finally
ReleaseEvalValue(Value);
end;
end;
function TPas2JSResolver.GetElementData(El: TPasElementBase;
DataClass: TPas2JsElementDataClass): TPas2JsElementData;
begin
@ -12823,11 +12915,14 @@ var
C: TClass;
AssignSt: TJSSimpleAssignStatement;
NeedInitFunction, HasConstructor: Boolean;
Proc: TPasProcedure;
aResolver: TPas2JSResolver;
begin
Result:=nil;
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertClassType START ',GetObjName(El));
{$ENDIF}
aResolver:=AContext.Resolver;
if not (El.ObjKind in [okClass,okInterface,okClassHelper,okRecordHelper,okTypeHelper]) then
RaiseNotSupported(El,AContext,20170927183645);
if El.Parent is TProcedureBody then
@ -12850,6 +12945,8 @@ begin
Ancestor:=nil;
IsTObject:=(El.ObjKind=okClass) and SameText(El.Name,'TObject');
end;
FreeAndNil(Scope.MsgIntToProc);
FreeAndNil(Scope.MsgStrToProc);
end
else
begin
@ -13012,6 +13109,7 @@ begin
NewEl:=nil;
C:=P.ClassType;
if not (P is TPasProcedure) then continue;
Proc:=TPasProcedure(P);
if IsTObject and (C=TPasDestructor) then
begin
DestructorName:=TransformVariableName(P,AContext);
@ -13029,10 +13127,12 @@ begin
else if (C=TPasClassConstructor)
or (C=TPasClassDestructor) then
begin
AddGlobalClassMethod(AContext,TPasProcedure(P));
AddGlobalClassMethod(AContext,Proc);
continue;
end;
NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
end
else if (Proc.MessageExpr<>nil) and (aResolver<>nil) then
aResolver.AddMessageIdToClassScope(Proc);
NewEl:=ConvertProcedure(Proc,FuncContext);
if NewEl=nil then
continue; // e.g. abstract or external proc
AddToSourceElements(Src,NewEl);
@ -13041,13 +13141,16 @@ begin
AddHelperConstructor(El,Src,FuncContext);
end;
// add interfaces
if (El.ObjKind=okClass) and (AContext.Resolver<>nil) then
AddClassSupportedInterfaces(El,Src,FuncContext);
// add RTTI init function
if AContext.Resolver<>nil then
if aResolver<>nil then
begin
// add interfaces
if (El.ObjKind=okClass) then
AddClassSupportedInterfaces(El,Src,FuncContext);
AddClassMessageIds(El,Src,FuncContext,pbivnMessageInt);
AddClassMessageIds(El,Src,FuncContext,pbivnMessageStr);
// add RTTI init function
AddClassRTTI(El,Src,FuncContext);
end;
end;// end of init function
@ -15764,6 +15867,44 @@ begin
end;
end;
procedure TPasToJSConverter.AddClassMessageIds(El: TPasClassType;
Src: TJSSourceElements; FuncContext: TFunctionContext;
pbivn: TPas2JSBuiltInName);
// $msgint = { id1:"proc1name", id2: "proc2name" ... }
var
Scope: TPas2JSClassScope;
List: TMessageIdToProc_List;
i: Integer;
AssignSt: TJSSimpleAssignStatement;
ObjLit: TJSObjectLiteral;
LitEl: TJSObjectLiteralElement;
Proc: TPasProcedure;
begin
Scope:=TPas2JSClassScope(El.CustomData);
case pbivn of
pbivnMessageInt: List:=Scope.MsgIntToProc;
pbivnMessageStr: List:=Scope.MsgStrToProc;
else
RaiseNotSupported(El,FuncContext,20190304001209,GetBIName(pbivn));
end;
if (List=nil) or (List.Count=0) then exit;
// this.$msgint = {}
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AddToSourceElements(Src,AssignSt);
AssignSt.LHS:=CreateMemberExpression(['this',GetBIName(pbivn)]);
ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
AssignSt.Expr:=ObjLit;
for i:=0 to List.Count-1 do
begin
LitEl:=ObjLit.Elements.AddElement;
LitEl.Name:=TJSString(List[i]);
Proc:=TPasProcedure(List.Objects[i]);
LitEl.Expr:=CreateLiteralJSString(Proc,TJSString(TransformVariableName(Proc,FuncContext)));
end;
end;
function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement;
// El is a reference to a proc

2
packages/pastojs/src/pas2jsfiler.pp
View File

@ -3795,6 +3795,7 @@ begin
Obj.Add('Alias',El.AliasName);
DefProcMods:=GetDefaultProcModifiers(El);
WriteProcedureModifiers(Obj,'PMods',El.Modifiers,DefProcMods);
WriteExpr(Obj,El,'Msg',El.MessageExpr,aContext);
if (El.MessageName<>'') or (El.MessageType<>pmtNone) then
begin
Obj.Add('Message',El.MessageName);
@ -7574,6 +7575,7 @@ begin
El.LibrarySymbolName:=ReadExpr(Obj,El,'LibName',aContext);
El.DispIDExpr:=ReadExpr(Obj,El,'DispId',aContext);
ReadString(Obj,'Alias',El.AliasName,El);
El.MessageExpr:=ReadExpr(Obj,El,'Msg',aContext);
if ReadString(Obj,'Message',s,El) then
begin
El.MessageName:=s;

54
packages/pastojs/tests/tcmodules.pas
View File

@ -531,6 +531,8 @@ type
Procedure TestClass_TObjectFreeFunctionFail;
Procedure TestClass_TObjectFreePropertyFail;
Procedure TestClass_ForIn;
Procedure TestClass_Message;
Procedure TestClass_Message_DuplicateIntFail;
// class of
Procedure TestClassOf_Create;
@ -14347,6 +14349,58 @@ begin
'']));
end;
procedure TTestModule.TestClass_Message;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' procedure Fly(var Msg); virtual; abstract; message 2;',
' procedure Run; overload; virtual; abstract;',
' procedure Run(var Msg); overload; message ''Fast'';',
' end;',
'procedure TObject.Run(var Msg);',
'begin',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestClass_Message',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Run$1 = function (Msg) {',
' };',
' this.$msgint = {',
' "2": "Fly"',
' };',
' this.$msgstr = {',
' Fast: "Run$1"',
' };',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestClass_Message_DuplicateIntFail;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' procedure Fly(var Msg); virtual; abstract; message 3;',
' procedure Run(var Msg); virtual; abstract; message 1+2;',
' end;',
'begin',
'']);
SetExpectedPasResolverError('Duplicate message id "3" at test1.pp(5,56)',nDuplicateMessageIdXAtY);
ConvertProgram;
end;
procedure TTestModule.TestClassOf_Create;
begin
StartProgram(false);

9
utils/pas2js/docs/translation.html
View File

@ -798,9 +798,9 @@ function(){
<ul>
<li>Local variables become local JavaScript variables: <i>var l = 0;</i>.</li>
<li>Local constants become JavaScript variables in the unit/program implementation section.</li>
<li>Overloaded functions are given an unique name by appending $1, $2, ...<br>
Overloading is always on. You don't need to add the <i>overload</i> modifier.</li>
<li>Supported: default values, local types, FuncName:=</li>
<li>Local types are elevated to module.</li>
<li>Overloaded functions are given an unique name by appending $1, $2, ...</li>
<li>Supported: default values, const/var/out/default, FuncName:=</li>
</ul>
</div>
@ -1612,7 +1612,8 @@ function(){
<li>private, protected, public, strict private, strict protected</li>
<li>class vars, const, nested types</li>
<li>methods, class methods, class constructor, external methods</li>
<li>method modifiers overload, reintroduce, virtual, override, abstract, static, external name</li>
<li>method modifiers overload, reintroduce, virtual, override, abstract,
static, external name, message integer, message string</li>
<li>call inherited</li>
<li>assigned()</li>
<li>type cast</li>