mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-31 01:12:04 +02:00
pastojs: directives DispatchField and DispatchStrField
git-svn-id: trunk@41680 -
This commit is contained in:
Mattias Gaertner
parent
7c910ee9ca
commit
4cbe5776b5
@ -79,6 +79,7 @@ const
|
||||
nErrIncludeLimitReached = 1028;
|
||||
nMisplacedGlobalCompilerSwitch = 1029;
|
||||
nLogMacroXSetToY = 1030;
|
||||
nInvalidDispatchFieldName = 1031;
|
||||
|
||||
// resourcestring patterns of messages
|
||||
resourcestring
|
||||
@ -114,6 +115,7 @@ resourcestring
|
||||
SErrIncludeLimitReached = 'Include file limit reached';
|
||||
SMisplacedGlobalCompilerSwitch = 'Misplaced global compiler switch, ignored';
|
||||
SLogMacroXSetToY = 'Macro %s set to %s';
|
||||
SInvalidDispatchFieldName = 'Invalid Dispatch field name';
|
||||
|
||||
type
|
||||
TMessageType = (
|
||||
@ -378,13 +380,19 @@ const
|
||||
|
||||
type
|
||||
TValueSwitch = (
|
||||
vsInterfaces
|
||||
vsInterfaces,
|
||||
vsDispatchField,
|
||||
vsDispatchStrField
|
||||
);
|
||||
TValueSwitches = set of TValueSwitch;
|
||||
TValueSwitchArray = array[TValueSwitch] of string;
|
||||
const
|
||||
vsAllValueSwitches = [low(TValueSwitch)..high(TValueSwitch)];
|
||||
DefaultVSInterfaces = 'com';
|
||||
DefaultValueSwitches: array[TValueSwitch] of string = (
|
||||
'com', // vsInterfaces
|
||||
'Msg', // vsDispatchField
|
||||
'MsgStr' // vsDispatchStrField
|
||||
);
|
||||
DefaultMaxIncludeStackDepth = 20;
|
||||
|
||||
type
|
||||
@ -765,6 +773,8 @@ type
|
||||
function HandleDirective(const ADirectiveText: String): TToken; virtual;
|
||||
function HandleLetterDirective(Letter: char; Enable: boolean): TToken; virtual;
|
||||
procedure HandleBoolDirective(bs: TBoolSwitch; const Param: String); virtual;
|
||||
procedure DoHandleDirective(Sender: TObject; Directive, Param: String;
|
||||
var Handled: boolean); virtual;
|
||||
procedure HandleIFDEF(const AParam: String);
|
||||
procedure HandleIFNDEF(const AParam: String);
|
||||
procedure HandleIFOPT(const AParam: String);
|
||||
@ -773,6 +783,7 @@ type
|
||||
procedure HandleELSE(const AParam: String);
|
||||
procedure HandleENDIF(const AParam: String);
|
||||
procedure HandleDefine(Param: String); virtual;
|
||||
procedure HandleDispatchField(Param: String; vs: TValueSwitch); virtual;
|
||||
procedure HandleError(Param: String); virtual;
|
||||
procedure HandleMessageDirective(Param: String); virtual;
|
||||
procedure HandleIncludeFile(Param: String); virtual;
|
||||
@ -1108,7 +1119,9 @@ const
|
||||
);
|
||||
|
||||
ValueSwitchNames: array[TValueSwitch] of string = (
|
||||
'Interfaces'
|
||||
'Interfaces', // vsInterfaces
|
||||
'DispatchField', // vsDispatchField
|
||||
'DispatchStrField' // vsDispatchStrField
|
||||
);
|
||||
|
||||
const
|
||||
@ -2657,6 +2670,8 @@ constructor TPascalScanner.Create(AFileResolver: TBaseFileResolver);
|
||||
Result.Duplicates:=dupError;
|
||||
end;
|
||||
|
||||
var
|
||||
vs: TValueSwitch;
|
||||
begin
|
||||
inherited Create;
|
||||
FFileResolver := AFileResolver;
|
||||
@ -2671,7 +2686,8 @@ begin
|
||||
FCurrentBoolSwitches:=bsFPCMode;
|
||||
FAllowedBoolSwitches:=bsAll;
|
||||
FAllowedValueSwitches:=vsAllValueSwitches;
|
||||
FCurrentValueSwitches[vsInterfaces]:=DefaultVSInterfaces;
|
||||
for vs in TValueSwitch do
|
||||
FCurrentValueSwitches[vs]:=DefaultValueSwitches[vs];
|
||||
|
||||
FConditionEval:=TCondDirectiveEvaluator.Create;
|
||||
FConditionEval.OnLog:=@OnCondEvalLog;
|
||||
@ -3297,6 +3313,26 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPascalScanner.HandleDispatchField(Param: String; vs: TValueSwitch);
|
||||
var
|
||||
NewValue: String;
|
||||
begin
|
||||
if not (vs in AllowedValueSwitches) then
|
||||
Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
|
||||
NewValue:=ReadIdentifier(Param);
|
||||
if NewValue='-' then
|
||||
NewValue:=''
|
||||
else if not IsValidIdent(NewValue,false) then
|
||||
DoLog(mtWarning,nInvalidDispatchFieldName,SInvalidDispatchFieldName,[]);
|
||||
if SameText(NewValue,CurrentValueSwitch[vs]) then exit;
|
||||
if vs in ReadOnlyValueSwitches then
|
||||
begin
|
||||
Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
|
||||
exit;
|
||||
end;
|
||||
CurrentValueSwitch[vs]:=NewValue;
|
||||
end;
|
||||
|
||||
procedure TPascalScanner.HandleError(Param: String);
|
||||
begin
|
||||
if po_StopOnErrorDirective in Options then
|
||||
@ -3682,6 +3718,10 @@ begin
|
||||
HandleDefine(Param);
|
||||
'GOTO':
|
||||
DoBoolDirective(bsGoto);
|
||||
'DIRECTIVEFIELD':
|
||||
HandleDispatchField(Param,vsDispatchField);
|
||||
'DIRECTIVESTRFIELD':
|
||||
HandleDispatchField(Param,vsDispatchStrField);
|
||||
'ERROR':
|
||||
HandleError(Param);
|
||||
'HINT':
|
||||
@ -3735,8 +3775,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
if Assigned(OnDirective) then
|
||||
OnDirective(Self,Directive,Param,Handled);
|
||||
DoHandleDirective(Self,Directive,Param,Handled);
|
||||
if (not Handled) then
|
||||
if LogEvent(sleDirective) then
|
||||
DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,
|
||||
@ -3801,6 +3840,13 @@ begin
|
||||
CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
|
||||
end;
|
||||
|
||||
procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
|
||||
Param: String; var Handled: boolean);
|
||||
begin
|
||||
if Assigned(OnDirective) then
|
||||
OnDirective(Self,Directive,Param,Handled);
|
||||
end;
|
||||
|
||||
function TPascalScanner.DoFetchToken: TToken;
|
||||
var
|
||||
TokenStart: {$ifdef UsePChar}PChar{$else}integer{$endif};
|
||||
|
||||
@ -522,6 +522,7 @@ const
|
||||
nHelperClassMethodForExtClassMustBeStatic = 4027;
|
||||
nBitWiseOperationIs32Bit = 4028;
|
||||
nDuplicateMessageIdXAtY = 4029;
|
||||
nDispatchRequiresX = 4030;
|
||||
// resourcestring patterns of messages
|
||||
resourcestring
|
||||
sPasElementNotSupported = 'Pascal element not supported: %s';
|
||||
@ -553,6 +554,7 @@ resourcestring
|
||||
sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static';
|
||||
sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit';
|
||||
sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
|
||||
sDispatchRequiresX = 'Dispatch requires %s';
|
||||
|
||||
const
|
||||
ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
|
||||
@ -1129,7 +1131,13 @@ type
|
||||
public
|
||||
NewInstanceFunction: TPasClassFunction;
|
||||
GUID: string;
|
||||
MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // temporary lists, not stored by filer!
|
||||
// Dispatch and message modifiers:
|
||||
DispatchProc: TPasProcedure;
|
||||
DispatchField: String;
|
||||
DispatchStrProc: TPasProcedure;
|
||||
DispatchStrField: String;
|
||||
MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // // not stored by filer
|
||||
public
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
@ -1194,10 +1202,10 @@ const
|
||||
msOmitRTTI,
|
||||
msMultiHelpers];
|
||||
|
||||
msAllPas2jsBoolSwitchesReadOnly = [
|
||||
bsAllPas2jsBoolSwitchesReadOnly = [
|
||||
bsLongStrings
|
||||
];
|
||||
msAllPas2jsBoolSwitches = msAllPas2jsBoolSwitchesReadOnly+[
|
||||
bsAllPas2jsBoolSwitches = bsAllPas2jsBoolSwitchesReadOnly+[
|
||||
bsAssertions,
|
||||
bsRangeChecks,
|
||||
bsWriteableConst,
|
||||
@ -1211,6 +1219,13 @@ const
|
||||
bsObjectChecks
|
||||
];
|
||||
|
||||
vsAllPas2jsValueSwitchesReadOnly = [];
|
||||
vsAllPas2jsValueSwitches = vsAllPas2jsValueSwitchesReadOnly+[
|
||||
vsInterfaces,
|
||||
vsDispatchField,
|
||||
vsDispatchStrField
|
||||
];
|
||||
|
||||
// default parser+scanner options
|
||||
po_Pas2js = po_Resolver+[
|
||||
po_AsmWhole,
|
||||
@ -1417,8 +1432,9 @@ type
|
||||
function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
|
||||
function IsTGUID(TypeEl: TPasRecordType): boolean; override;
|
||||
function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
|
||||
procedure CheckDispatchField(Proc: TPasProcedure; Switch: TValueSwitch);
|
||||
procedure AddMessageStr(var MsgToProc: TMessageIdToProc_List; const S: string; Proc: TPasProcedure);
|
||||
procedure AddMessageIdToClassScope(Proc: TPasProcedure); virtual;
|
||||
procedure AddMessageIdToClassScope(Proc: TPasProcedure; EmitHints: boolean); virtual;
|
||||
// CustomData
|
||||
function GetElementData(El: TPasElementBase;
|
||||
DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
|
||||
@ -3567,6 +3583,10 @@ begin
|
||||
until false;
|
||||
end;
|
||||
end;
|
||||
|
||||
// clear
|
||||
Scope.MsgIntToProc:=nil;
|
||||
Scope.MsgStrToProc:=nil;
|
||||
//writeln('TPas2JSResolver.FinishClassType END ',GetObjName(El));
|
||||
end;
|
||||
|
||||
@ -3818,7 +3838,7 @@ procedure TPas2JSResolver.FinishProcedureType(El: TPasProcedureType);
|
||||
var
|
||||
Proc: TPasProcedure;
|
||||
pm: TProcedureModifier;
|
||||
ExtName: String;
|
||||
ExtName, s: String;
|
||||
C: TClass;
|
||||
AClassOrRec: TPasMembersType;
|
||||
ClassOrRecScope: TPasClassOrRecordScope;
|
||||
@ -3882,7 +3902,7 @@ begin
|
||||
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);
|
||||
AddMessageIdToClassScope(Proc,true);
|
||||
end;
|
||||
|
||||
if Proc.Parent is TPasMembersType then
|
||||
@ -3981,6 +4001,27 @@ begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if (Proc.ClassType=TPasProcedure) and (Proc.ProcType.Args.Count=1) then
|
||||
begin
|
||||
if SameText(Proc.Name,'Dispatch') then
|
||||
begin
|
||||
s:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchField];
|
||||
if s<>'' then
|
||||
begin
|
||||
ClassScope.DispatchField:=s;
|
||||
ClassScope.DispatchProc:=Proc;
|
||||
end;
|
||||
end
|
||||
else if SameText(Proc.Name,'DispatchStr') then
|
||||
begin
|
||||
s:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchStrField];
|
||||
if s<>'' then
|
||||
begin
|
||||
ClassScope.DispatchStrField:=s;
|
||||
ClassScope.DispatchStrProc:=Proc;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
@ -5446,6 +5487,88 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.CheckDispatchField(Proc: TPasProcedure;
|
||||
Switch: TValueSwitch);
|
||||
var
|
||||
ProcScope: TPas2JSProcedureScope;
|
||||
ClassScope: TPas2JSClassScope;
|
||||
FieldName: String;
|
||||
Args, Members: TFPList;
|
||||
Arg: TPasArgument;
|
||||
ArgType: TPasType;
|
||||
i: Integer;
|
||||
Member: TPasElement;
|
||||
MemberResolved: TPasResolverResult;
|
||||
begin
|
||||
Args:=Proc.ProcType.Args;
|
||||
if Args.Count<>1 then
|
||||
RaiseNotYetImplemented(20190311213959,Proc);
|
||||
Arg:=TPasArgument(Args[0]);
|
||||
if Arg.ArgType=nil then
|
||||
exit; // untyped arg
|
||||
|
||||
ProcScope:=TPas2JSProcedureScope(Proc.CustomData);
|
||||
ClassScope:=TPas2JSClassScope(ProcScope.ClassRecScope);
|
||||
FieldName:='';
|
||||
while ClassScope<>nil do
|
||||
begin
|
||||
case Switch of
|
||||
vsDispatchField:
|
||||
if ClassScope.DispatchField<>'' then
|
||||
begin
|
||||
FieldName:=ClassScope.DispatchField;
|
||||
break;
|
||||
end;
|
||||
vsDispatchStrField:
|
||||
if ClassScope.DispatchStrField<>'' then
|
||||
begin
|
||||
FieldName:=ClassScope.DispatchStrField;
|
||||
break;
|
||||
end;
|
||||
else
|
||||
RaiseNotYetImplemented(20190311213650,Proc,'');
|
||||
end;
|
||||
ClassScope:=ClassScope.AncestorScope as TPas2JSClassScope;
|
||||
end;
|
||||
if FieldName='' then exit;
|
||||
|
||||
// there is a Dispatch(str) method with a directive -> check field
|
||||
ArgType:=ResolveAliasType(Arg.ArgType);
|
||||
if not (ArgType is TPasMembersType) then
|
||||
begin
|
||||
LogMsg(20190311214257,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['record type'],Arg);
|
||||
exit;
|
||||
end;
|
||||
Members:=TPasMembersType(ArgType).Members;
|
||||
for i:=0 to Members.Count-1 do
|
||||
begin
|
||||
Member:=TPasElement(Members[i]);
|
||||
if SameText(Member.Name,FieldName) then
|
||||
begin
|
||||
if Member.ClassType<>TPasVariable then
|
||||
begin
|
||||
LogMsg(20190311215218,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['field variable "'+FieldName+'"'],Arg);
|
||||
exit;
|
||||
end;
|
||||
// field found -> check type
|
||||
ComputeElement(TPasVariable(Member).VarType,MemberResolved,[rcType],Arg);
|
||||
if not (MemberResolved.BaseType in btAllJSInteger) then
|
||||
begin
|
||||
LogMsg(20190311215215,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['integer field "'+FieldName+'"'],Arg);
|
||||
exit;
|
||||
end;
|
||||
// check name case
|
||||
if Member.Name<>FieldName then
|
||||
begin
|
||||
LogMsg(20190311221651,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['field name to match exactly "'+FieldName+'"'],Arg);
|
||||
exit;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
LogMsg(20190311214710,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['record field "'+FieldName+'"'],Arg);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.AddMessageStr(var MsgToProc: TMessageIdToProc_List;
|
||||
const S: string; Proc: TPasProcedure);
|
||||
var
|
||||
@ -5464,7 +5587,8 @@ begin
|
||||
MsgToProc.AddObject(S,Proc);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure);
|
||||
procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure;
|
||||
EmitHints: boolean);
|
||||
var
|
||||
AClass: TPasClassType;
|
||||
ClassScope: TPas2JSClassScope;
|
||||
@ -5481,12 +5605,24 @@ begin
|
||||
case Value.Kind of
|
||||
{$ifdef FPC_HAS_CPSTRING}
|
||||
revkString:
|
||||
begin
|
||||
AddMessageStr(ClassScope.MsgStrToProc,ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr),Proc);
|
||||
if EmitHints then
|
||||
CheckDispatchField(Proc,vsDispatchStrField);
|
||||
end;
|
||||
{$ENDIF}
|
||||
revkUnicodeString:
|
||||
begin
|
||||
AddMessageStr(ClassScope.MsgStrToProc,String(TResEvalUTF16(Value).S),Proc);
|
||||
if EmitHints then
|
||||
CheckDispatchField(Proc,vsDispatchStrField);
|
||||
end;
|
||||
revkInt:
|
||||
begin
|
||||
AddMessageStr(ClassScope.MsgIntToProc,IntToStr(TResEvalInt(Value).Int),Proc);
|
||||
if EmitHints then
|
||||
CheckDispatchField(Proc,vsDispatchField);
|
||||
end
|
||||
else
|
||||
RaiseXExpectedButYFound(20190303225849,'integer constant',Value.AsString,Expr);
|
||||
end;
|
||||
@ -13240,7 +13376,7 @@ begin
|
||||
continue;
|
||||
end
|
||||
else if (Proc.MessageExpr<>nil) and (aResolver<>nil) then
|
||||
aResolver.AddMessageIdToClassScope(Proc);
|
||||
aResolver.AddMessageIdToClassScope(Proc,false);
|
||||
NewEl:=ConvertProcedure(Proc,FuncContext);
|
||||
if NewEl=nil then
|
||||
continue; // e.g. abstract or external proc
|
||||
|
||||
@ -1044,9 +1044,11 @@ begin
|
||||
Scanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
|
||||
Scanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
|
||||
Scanner.CurrentModeSwitches:=GetInitialModeSwitches;
|
||||
Scanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
|
||||
Scanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
|
||||
Scanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
|
||||
Scanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
|
||||
Scanner.CurrentBoolSwitches:=GetInitialBoolSwitches;
|
||||
Scanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
|
||||
Scanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
|
||||
Scanner.CurrentValueSwitch[vsInterfaces]:=InterfaceTypeNames[Compiler.InterfaceType];
|
||||
if coAllowCAssignments in Compiler.Options then
|
||||
Scanner.Options:=Scanner.Options+[po_cassignments];
|
||||
|
||||
@ -853,6 +853,8 @@ type
|
||||
procedure Set_ClassScope_NewInstanceFunction(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DirectAncestor(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DefaultProperty(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DispatchProc(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DispatchStrProc(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassType_AncestorType(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassType_HelperForType(RefEl: TPasElement; Data: TObject);
|
||||
@ -971,6 +973,7 @@ type
|
||||
procedure ReadClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
|
||||
procedure ReadClassIntfMap(Obj: TJSONObject; Scope: TPas2JSClassScope; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
|
||||
procedure ReadClassScopeInterfaces(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
|
||||
procedure ReadClassScopeDispatchProcs(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
|
||||
procedure ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadClassType(Obj: TJSONObject; El: TPasClassType; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadArgument(Obj: TJSONObject; El: TPasArgument; aContext: TPCUReaderContext); virtual;
|
||||
@ -3494,6 +3497,13 @@ begin
|
||||
AddReferenceToArray(Arr,Scope.AbstractProcs[i]);
|
||||
end;
|
||||
|
||||
AddReferenceToObj(Obj,'DispatchProc',Scope.DispatchProc);
|
||||
if Scope.DispatchField<>'' then
|
||||
Obj.Add('DispatchField',Scope.DispatchField);
|
||||
AddReferenceToObj(Obj,'DispatchStrProc',Scope.DispatchStrProc);
|
||||
if Scope.DispatchStrField<>'' then
|
||||
Obj.Add('DispatchStrField',Scope.DispatchStrField);
|
||||
|
||||
if Scope.GUID<>'' then
|
||||
Obj.Add('SGUID',Scope.GUID);
|
||||
|
||||
@ -4335,6 +4345,28 @@ begin
|
||||
RaiseMsg(20180214115044,Scope.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ClassScope_DispatchProc(RefEl: TPasElement;
|
||||
Data: TObject);
|
||||
var
|
||||
Scope: TPas2JSClassScope absolute Data;
|
||||
begin
|
||||
if RefEl is TPasProcedure then
|
||||
Scope.DispatchProc:=TPasProcedure(RefEl) // no AddRef
|
||||
else
|
||||
RaiseMsg(20190311220755,Scope.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ClassScope_DispatchStrProc(RefEl: TPasElement;
|
||||
Data: TObject);
|
||||
var
|
||||
Scope: TPas2JSClassScope absolute Data;
|
||||
begin
|
||||
if RefEl is TPasProcedure then
|
||||
Scope.DispatchStrProc:=TPasProcedure(RefEl) // no AddRef
|
||||
else
|
||||
RaiseMsg(20190311220757,Scope.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
|
||||
var
|
||||
Map: TPasClassIntfMap absolute Data;
|
||||
@ -7002,6 +7034,18 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassScopeDispatchProcs(Obj: TJSONObject;
|
||||
Scope: TPas2JSClassScope);
|
||||
var
|
||||
El: TPasClassType;
|
||||
begin
|
||||
El:=TPasClassType(Scope.Element);
|
||||
ReadString(Obj,'DispatchField',Scope.DispatchField,El);
|
||||
ReadString(Obj,'DispatchStrField',Scope.DispatchStrField,El);
|
||||
ReadElementReference(Obj,Scope,'DispatchProc',@Set_ClassScope_DispatchProc);
|
||||
ReadElementReference(Obj,Scope,'DispatchStrProc',@Set_ClassScope_DispatchStrProc);
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;
|
||||
aContext: TPCUReaderContext);
|
||||
var
|
||||
@ -7098,10 +7142,13 @@ begin
|
||||
ReadElementList(Obj,El,'Members',El.Members,
|
||||
{$IFDEF CheckPasTreeRefCount}'TPasClassType.Members'{$ELSE}true{$ENDIF},
|
||||
aContext);
|
||||
|
||||
|
||||
if Scope<>nil then
|
||||
begin
|
||||
ReadClassScopeAbstractProcs(Obj,Scope);
|
||||
ReadClassScopeInterfaces(Obj,Scope);
|
||||
ReadClassScopeDispatchProcs(Obj,Scope);
|
||||
|
||||
if El.ObjKind in okAllHelpers then
|
||||
begin
|
||||
|
||||
@ -161,6 +161,7 @@ type
|
||||
procedure TestPC_Class;
|
||||
procedure TestPC_ClassForward;
|
||||
procedure TestPC_ClassConstructor;
|
||||
procedure TestPC_ClassDispatchMessage;
|
||||
procedure TestPC_Initialization;
|
||||
procedure TestPC_BoolSwitches;
|
||||
procedure TestPC_ClassInterface;
|
||||
@ -748,6 +749,10 @@ begin
|
||||
|
||||
CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
|
||||
AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
|
||||
CheckRestoredReference(Path+'.DispatchProc',Orig.DispatchProc,Rest.DispatchProc);
|
||||
AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
|
||||
CheckRestoredReference(Path+'.DispatchStrProc',Orig.DispatchStrProc,Rest.DispatchStrProc);
|
||||
AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
|
||||
|
||||
CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
|
||||
if Orig.Interfaces<>nil then
|
||||
@ -2143,6 +2148,40 @@ begin
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_ClassDispatchMessage;
|
||||
begin
|
||||
StartUnit(false);
|
||||
Add([
|
||||
'interface',
|
||||
'type',
|
||||
' TObject = class',
|
||||
' {$DispatchField DispInt}',
|
||||
' procedure Dispatch(var Msg); virtual; abstract;',
|
||||
' {$DispatchStrField DispStr}',
|
||||
' procedure DispatchStr(var Msg); virtual; abstract;',
|
||||
' end;',
|
||||
' THopMsg = record',
|
||||
' DispInt: longint;',
|
||||
' end;',
|
||||
' TPutMsg = record',
|
||||
' DispStr: string;',
|
||||
' end;',
|
||||
' TBird = class',
|
||||
' procedure Fly(var Msg); virtual; abstract; message 2;',
|
||||
' procedure Run; overload; virtual; abstract;',
|
||||
' procedure Run(var Msg); overload; message ''Fast'';',
|
||||
' procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
|
||||
' procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
|
||||
' end;',
|
||||
'implementation',
|
||||
'procedure TBird.Run(var Msg);',
|
||||
'begin',
|
||||
'end;',
|
||||
'end.',
|
||||
'']);
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_Initialization;
|
||||
begin
|
||||
StartUnit(false);
|
||||
|
||||
@ -533,8 +533,9 @@ type
|
||||
Procedure TestClass_TObjectFreeFunctionFail;
|
||||
Procedure TestClass_TObjectFreePropertyFail;
|
||||
Procedure TestClass_ForIn;
|
||||
Procedure TestClass_Message;
|
||||
Procedure TestClass_DispatchMessage;
|
||||
Procedure TestClass_Message_DuplicateIntFail;
|
||||
Procedure TestClass_DispatchMessage_WrongFieldNameFail;
|
||||
|
||||
// class of
|
||||
Procedure TestClassOf_Create;
|
||||
@ -1297,9 +1298,12 @@ begin
|
||||
aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
|
||||
aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
|
||||
|
||||
aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
|
||||
aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
|
||||
aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
|
||||
aScanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
|
||||
aScanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
|
||||
aScanner.CurrentBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
|
||||
|
||||
aScanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
|
||||
aScanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
|
||||
|
||||
aScanner.OnLog:=@OnScannerLog;
|
||||
|
||||
@ -14419,17 +14423,31 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClass_Message;
|
||||
procedure TTestModule.TestClass_DispatchMessage;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' {$DispatchField DispInt}',
|
||||
' procedure Dispatch(var Msg); virtual; abstract;',
|
||||
' {$DispatchStrField DispStr}',
|
||||
' procedure DispatchStr(var Msg); virtual; abstract;',
|
||||
' end;',
|
||||
' THopMsg = record',
|
||||
' DispInt: longint;',
|
||||
' end;',
|
||||
' TPutMsg = record',
|
||||
' DispStr: string;',
|
||||
' end;',
|
||||
' TBird = class',
|
||||
' procedure Fly(var Msg); virtual; abstract; message 2;',
|
||||
' procedure Run; overload; virtual; abstract;',
|
||||
' procedure Run(var Msg); overload; message ''Fast'';',
|
||||
' procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
|
||||
' procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
|
||||
' end;',
|
||||
'procedure TObject.Run(var Msg);',
|
||||
'procedure TBird.Run(var Msg);',
|
||||
'begin',
|
||||
'end;',
|
||||
'begin',
|
||||
@ -14442,13 +14460,37 @@ begin
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.recNewT($mod, "THopMsg", function () {',
|
||||
' this.DispInt = 0;',
|
||||
' this.$eq = function (b) {',
|
||||
' return this.DispInt === b.DispInt;',
|
||||
' };',
|
||||
' this.$assign = function (s) {',
|
||||
' this.DispInt = s.DispInt;',
|
||||
' return this;',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.recNewT($mod, "TPutMsg", function () {',
|
||||
' this.DispStr = "";',
|
||||
' this.$eq = function (b) {',
|
||||
' return this.DispStr === b.DispStr;',
|
||||
' };',
|
||||
' this.$assign = function (s) {',
|
||||
' this.DispStr = s.DispStr;',
|
||||
' return this;',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.Run$1 = function (Msg) {',
|
||||
' };',
|
||||
' this.$msgint = {',
|
||||
' "2": "Fly"',
|
||||
' "2": "Fly",',
|
||||
' "3": "Hop"',
|
||||
' };',
|
||||
' this.$msgstr = {',
|
||||
' Fast: "Run$1"',
|
||||
' Fast: "Run$1",',
|
||||
' foo: "Put"',
|
||||
' };',
|
||||
'});',
|
||||
'']),
|
||||
@ -14471,6 +14513,27 @@ begin
|
||||
ConvertProgram;
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClass_DispatchMessage_WrongFieldNameFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' {$dispatchfield Msg}',
|
||||
' procedure Dispatch(var Msg); virtual; abstract;',
|
||||
' end;',
|
||||
' TFlyMsg = record',
|
||||
' FlyId: longint;',
|
||||
' end;',
|
||||
' TBird = class',
|
||||
' procedure Fly(var Msg: TFlyMsg); virtual; abstract; message 3;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckHint(mtWarning,nDispatchRequiresX,'Dispatch requires record field "Msg"');
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassOf_Create;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user