diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index e4687fe4b9..65f983edef 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -325,6 +325,9 @@ Works: - Currency:=Double -> Currency:=Math.floor(Double*10000) - jsvalue := currency -> jsvalue:=currency/10000 - simplify Math.floor(number) to trunc(number) +- Pointer of record + - p:=@r, p^:=r + - p^.x, p.x ToDos: - for i in jsvalue do @@ -1183,6 +1186,8 @@ type function CreateElementData(DataClass: TPas2JsElementDataClass; El: TPasElement): TPas2JsElementData; virtual; // utility + procedure RaiseMsg(const Id: int64; MsgNumber: integer; const Fmt: String; + Args: array of const; ErrorPosEl: TPasElement); override; function GetOverloadName(El: TPasElement): string; function GetBaseDescription(const R: TPasResolverResult; AddPath: boolean= false): string; override; @@ -2437,6 +2442,7 @@ var i: Integer; Decl: TPasElement; C: TClass; + TypeEl: TPasType; begin inherited FinishTypeSection(El); for i:=0 to El.Declarations.Count-1 do @@ -2445,8 +2451,11 @@ begin C:=Decl.ClassType; if C=TPasPointerType then begin - // ToDo: pointer of record - RaiseMsg(20180423105726,nNotSupportedX,sNotSupportedX,['pointer of '+TPasPointerType(Decl).DestType.Name],El); + TypeEl:=ResolveAliasType(TPasPointerType(Decl).DestType); + if TypeEl.ClassType=TPasRecordType then + // ^record + else + RaiseMsg(20180423105726,nNotSupportedX,sNotSupportedX,['pointer of '+TPasPointerType(Decl).DestType.Name],Decl); end; end; end; @@ -2684,7 +2693,7 @@ var AbsExpr: TPasExpr; ResolvedAbsol: TPasResolverResult; AbsIdent: TPasElement; - TypeEl: TPasType; + TypeEl, ElTypeEl: TPasType; GUID: TGUID; i: Integer; SectionScope: TPas2JSSectionScope; @@ -2813,7 +2822,13 @@ begin TypeEl:=ResolveAliasType(El.VarType); if TypeEl.ClassType=TPasPointerType then - RaiseMsg(20180423110113,nNotSupportedX,sNotSupportedX,['pointer'],El); + begin + ElTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType); + if ElTypeEl.ClassType=TPasRecordType then + // ^record + else + RaiseMsg(20180423110113,nNotSupportedX,sNotSupportedX,['pointer'],El); + end; if El.Expr<>nil then begin @@ -2830,7 +2845,7 @@ end; procedure TPas2JSResolver.FinishArgument(El: TPasArgument); var - TypeEl: TPasType; + TypeEl, ElTypeEl: TPasType; begin inherited FinishArgument(El); if El.ArgType<>nil then @@ -2838,7 +2853,13 @@ begin TypeEl:=ResolveAliasType(El.ArgType); if TypeEl.ClassType=TPasPointerType then - RaiseMsg(20180423110239,nNotSupportedX,sNotSupportedX,['pointer'],El); + begin + ElTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType); + if ElTypeEl.ClassType=TPasRecordType then + // ^record + else + RaiseMsg(20180423110239,nNotSupportedX,sNotSupportedX,['pointer'],El); + end; end; end; @@ -2851,7 +2872,7 @@ var AClass: TPasClassType; ClassScope: TPas2JSClassScope; ptm: TProcTypeModifier; - TypeEl: TPasType; + TypeEl, ElTypeEl: TPasType; begin inherited FinishProcedureType(El); @@ -2859,7 +2880,13 @@ begin begin TypeEl:=ResolveAliasType(TPasFunctionType(El).ResultEl.ResultType); if TypeEl.ClassType=TPasPointerType then - RaiseMsg(20180423110824,nNotSupportedX,sNotSupportedX,['pointer'],El); + begin + ElTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType); + if ElTypeEl.ClassType=TPasRecordType then + // ^record + else + RaiseMsg(20180423110824,nNotSupportedX,sNotSupportedX,['pointer'],El); + end; end; if El.Parent is TPasProcedure then @@ -4150,6 +4177,15 @@ begin AddElementData(Result); end; +procedure TPas2JSResolver.RaiseMsg(const Id: int64; MsgNumber: integer; + const Fmt: String; Args: array of const; ErrorPosEl: TPasElement); +begin + {$IFDEF VerbosePas2JS} + writeln('TPas2JSResolver.RaiseMsg [',Id,']'); + {$ENDIF} + inherited RaiseMsg(Id, MsgNumber, Fmt, Args, ErrorPosEl); +end; + function TPas2JSResolver.GetOverloadName(El: TPasElement): string; var Data: TObject; @@ -4898,29 +4934,42 @@ end; function TPasToJSConverter.ConvertUnaryExpression(El: TUnaryExpr; AContext: TConvertContext): TJSElement; - procedure NotSupported; + procedure NotSupported(Id: int64); var ResolvedEl: TPasResolverResult; begin if AContext.Resolver<>nil then begin AContext.Resolver.ComputeElement(El.Operand,ResolvedEl,[],El); - DoError(20180423111325,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf, + DoError(Id,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf, [OpcodeStrings[El.OpCode],AContext.Resolver.GetResolverResultDescription(ResolvedEl)],El); end else - DoError(20170215134950,nUnaryOpcodeNotSupported,sUnaryOpcodeNotSupported, + DoError(Id,nUnaryOpcodeNotSupported,sUnaryOpcodeNotSupported, [OpcodeStrings[El.OpCode]],El); end; + function DerefPointer(TypeEl: TPasType): boolean; + begin + if TypeEl.ClassType=TPasRecordType then + begin + // PRecordVar^ -> PRecordVar + ConvertUnaryExpression:=ConvertElement(El.Operand,AContext); + exit(true); + end; + Result:=false; + end; + Var U : TJSUnaryExpression; E : TJSElement; ResolvedOp, ResolvedEl: TPasResolverResult; BitwiseNot: Boolean; - + aResolver: TPas2JSResolver; + TypeEl, SubTypeEl: TPasType; begin if AContext=nil then ; + aResolver:=AContext.Resolver; Result:=Nil; U:=nil; Case El.OpCode of @@ -4940,9 +4989,9 @@ begin begin E:=ConvertElement(El.Operand,AContext); BitwiseNot:=true; - if AContext.Resolver<>nil then + if aResolver<>nil then begin - AContext.Resolver.ComputeElement(El.Operand,ResolvedOp,[]); + aResolver.ComputeElement(El.Operand,ResolvedOp,[]); BitwiseNot:=ResolvedOp.BaseType in btAllJSInteger; end; if BitwiseNot then @@ -4953,9 +5002,9 @@ begin end; eopAddress: begin - if AContext.Resolver=nil then - NotSupported; - AContext.Resolver.ComputeElement(El.Operand,ResolvedEl,[rcNoImplicitProc]); + if aResolver=nil then + NotSupported(20180423162321); + aResolver.ComputeElement(El.Operand,ResolvedEl,[rcNoImplicitProc]); {$IFDEF VerbosePas2JS} writeln('TPasToJSConverter.ConvertUnaryExpression ',GetResolverResultDbg(ResolvedEl)); {$ENDIF} @@ -4966,6 +5015,36 @@ begin Result:=CreateCallback(El.Operand,ResolvedEl,AContext); exit; end; + end + else if (ResolvedEl.BaseType=btContext) then + begin + TypeEl:=aResolver.ResolveAliasType(ResolvedEl.TypeEl); + if TypeEl.ClassType=TPasRecordType then + begin + // @RecVar -> RecVar + Result:=ConvertElement(El.Operand,AContext); + exit; + end; + end; + end; + eopDeref: + begin + if aResolver=nil then + NotSupported(20180423162350); + aResolver.ComputeElement(El.Operand,ResolvedEl,[rcNoImplicitProc]); + if ResolvedEl.BaseType=btPointer then + begin + TypeEl:=aResolver.ResolveAliasType(ResolvedEl.TypeEl); + if DerefPointer(TypeEl) then exit; + end + else if (ResolvedEl.BaseType=btContext) then + begin + TypeEl:=aResolver.ResolveAliasType(ResolvedEl.TypeEl); + if TypeEl.ClassType=TPasPointerType then + begin + SubTypeEl:=aResolver.ResolveAliasType(TPasPointerType(TypeEl).DestType); + if DerefPointer(SubTypeEl) then exit; + end; end; end; eopMemAddress: @@ -4976,7 +5055,7 @@ begin end; end; if U=nil then - NotSupported; + NotSupported(20180423162324); Result:=U; end; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 652670eb4a..2af5021958 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -547,6 +547,8 @@ type Procedure TestPointer_ArrayParamsFail; Procedure TestPointer_PointerAddFail; Procedure TestPointer_IncPointerFail; + Procedure TestPointer_Record; + Procedure TestPointer_RecordArg; // jsvalue Procedure TestJSValue_AssignToJSValue; @@ -16326,6 +16328,151 @@ begin ConvertProgram; end; +procedure TTestModule.TestPointer_Record; +begin + StartProgram(false); + Add([ + 'type', + ' TRec = record x: longint; end;', + ' PRec = ^TRec;', + 'var', + ' r: TRec;', + ' p: PRec;', + 'begin', + ' p:=@r;', + ' r:=p^;', + ' r.x:=p^.x;', + ' p^.x:=r.x;', + ' if p^.x=3 then ;', + ' if 4=p^.x then ;', + '']); + ConvertProgram; + CheckSource('TestPointer_Record', + LinesToStr([ // statements + 'this.TRec = function (s) {', + ' if (s) {', + ' this.x = s.x;', + ' } else {', + ' this.x = 0;', + ' };', + ' this.$equal = function (b) {', + ' return this.x === b.x;', + ' };', + '};', + 'this.r = new $mod.TRec();', + 'this.p = null;', + '']), + LinesToStr([ // $mod.$main + '$mod.p = $mod.r;', + '$mod.r = new $mod.TRec($mod.p);', + '$mod.r.x = $mod.p.x;', + '$mod.p.x = $mod.r.x;', + 'if ($mod.p.x === 3) ;', + 'if (4 === $mod.p.x) ;', + ''])); +end; + +procedure TTestModule.TestPointer_RecordArg; +begin + StartProgram(false); + Add([ + '{$modeswitch autoderef}', + 'type', + ' TRec = record x: longint; end;', + ' PRec = ^TRec;', + 'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;', + 'begin', + ' a.x:=a.x;', + ' a^.x:=a^.x;', + ' with a^ do', + ' x:=x;', + 'end;', + 'function GetIt(p: PRec): PRec;', + 'begin', + ' p.x:=p.x;', + ' p^.x:=p^.x;', + ' with p^ do', + ' x:=x;', + 'end;', + 'var', + ' r: TRec;', + ' p: PRec;', + 'begin', + ' p:=GetIt(p);', + ' p^:=GetIt(@r)^;', + ' DoIt(p,p,p);', + ' DoIt(@r,p,p);', + '']); + ConvertProgram; + CheckSource('TestPointer_Record', + LinesToStr([ // statements + 'this.TRec = function (s) {', + ' if (s) {', + ' this.x = s.x;', + ' } else {', + ' this.x = 0;', + ' };', + ' this.$equal = function (b) {', + ' return this.x === b.x;', + ' };', + '};', + 'this.DoIt = function (a, b, c) {', + ' var Result = new $mod.TRec();', + ' a.x = a.x;', + ' a.x = a.x;', + ' a.x = a.x;', + ' return Result;', + '};', + 'this.GetIt = function (p) {', + ' var Result = null;', + ' p.x = p.x;', + ' p.x = p.x;', + ' p.x = p.x;', + ' return Result;', + '};', + 'this.r = new $mod.TRec();', + 'this.p = null;', + '']), + LinesToStr([ // $mod.$main + '$mod.p = $mod.GetIt($mod.p);', + '$mod.p = new $mod.TRec($mod.GetIt($mod.r));', + '$mod.DoIt($mod.p, {', + ' p: $mod,', + ' get: function () {', + ' return this.p.p;', + ' },', + ' set: function (v) {', + ' this.p.p = v;', + ' }', + '}, {', + ' p: $mod,', + ' get: function () {', + ' return this.p.p;', + ' },', + ' set: function (v) {', + ' this.p.p = v;', + ' }', + '});', + '$mod.DoIt($mod.r, {', + ' p: $mod,', + ' get: function () {', + ' return this.p.p;', + ' },', + ' set: function (v) {', + ' this.p.p = v;', + ' }', + '}, {', + ' p: $mod,', + ' get: function () {', + ' return this.p.p;', + ' },', + ' set: function (v) {', + ' this.p.p = v;', + ' }', + '});', + ''])); +end; + procedure TTestModule.TestJSValue_AssignToJSValue; begin StartProgram(false);