From 4cbe5776b50433863e3ac48175a0e53dd34e40da Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Mon, 11 Mar 2019 21:41:44 +0000 Subject: [PATCH] pastojs: directives DispatchField and DispatchStrField git-svn-id: trunk@41680 - --- packages/fcl-passrc/src/pscanner.pp | 58 +++++++++- packages/pastojs/src/fppas2js.pp | 152 +++++++++++++++++++++++-- packages/pastojs/src/pas2jscompiler.pp | 6 +- packages/pastojs/src/pas2jsfiler.pp | 47 ++++++++ packages/pastojs/tests/tcfiler.pas | 39 +++++++ packages/pastojs/tests/tcmodules.pas | 79 +++++++++++-- 6 files changed, 357 insertions(+), 24 deletions(-) diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index ab1f2e00b6..f3d67722ff 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -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}; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index ffbb7c8642..8aae2ddbeb 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -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 diff --git a/packages/pastojs/src/pas2jscompiler.pp b/packages/pastojs/src/pas2jscompiler.pp index 094ec93eea..ae73791160 100644 --- a/packages/pastojs/src/pas2jscompiler.pp +++ b/packages/pastojs/src/pas2jscompiler.pp @@ -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]; diff --git a/packages/pastojs/src/pas2jsfiler.pp b/packages/pastojs/src/pas2jsfiler.pp index bf4607c09f..9978b50e25 100644 --- a/packages/pastojs/src/pas2jsfiler.pp +++ b/packages/pastojs/src/pas2jsfiler.pp @@ -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 diff --git a/packages/pastojs/tests/tcfiler.pas b/packages/pastojs/tests/tcfiler.pas index 966e3d6f2e..4575109e94 100644 --- a/packages/pastojs/tests/tcfiler.pas +++ b/packages/pastojs/tests/tcfiler.pas @@ -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); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 3a55bd1ab7..9bf6544cc3 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -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);