diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 17f73fdc0b..e4687fe4b9 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -252,6 +252,7 @@ Works: - property default value - pointer - compare with and assign nil + - typecast class, class-of, interface, array - ECMAScript6: - use 0b for binary literals - use 0o for octal literals @@ -995,22 +996,19 @@ const msClass, msResult, msRepeatForward, - // ToDo: msPointer2Procedure, - // ToDo: msAutoDeref, msInitFinal, msOut, msDefaultPara, - // ToDo: msDuplicateNames msProperty, - // ToDo: msDefaultInline msExcept, - // ToDo: msAdvancedRecords msDefaultUnicodestring, msCBlocks ]; msAllPas2jsModeSwitches = msAllPas2jsModeSwitchesReadOnly+[ msDelphi,msObjfpc, - msHintDirective,msNestedComment, + msAutoDeref, + msHintDirective, + msNestedComment, msExternalClass, msIgnoreAttributes]; @@ -1040,7 +1038,7 @@ const btString, btUnicodeString, btDouble, - btCurrency, // nativeint*10000 + btCurrency, // nativeint*10000 truncated btBoolean, btByteBool, btWordBool, @@ -1064,7 +1062,9 @@ const btAllJSFloats = [btDouble]; btAllJSBooleans = [btBoolean]; btAllJSInteger = [btByte,btShortInt,btWord,btSmallInt,btLongWord,btLongint, - btIntDouble,btUIntDouble,btCurrency]; + btIntDouble,btUIntDouble, + btCurrency // in pas2js currency is more like an integer, instead of float + ]; btAllJSValueSrcTypes = [btNil,btUntyped,btPointer]+btAllJSInteger +btAllJSStringAndChars+btAllJSFloats+btAllJSBooleans; btAllJSValueTypeCastTo = btAllJSInteger @@ -1079,7 +1079,8 @@ const proExtClassInstanceNoTypeMembers, proOpenAsDynArrays, proProcTypeWithoutIsNested, - proMethodAddrAsPointer + proMethodAddrAsPointer, + proNoPointerArithmetic ]; type TPas2JSResolver = class(TPasResolver) @@ -1109,6 +1110,7 @@ type procedure ResolveNameExpr(El: TPasExpr; const aName: string; Access: TResolvedRefAccess); override; procedure FinishInterfaceSection(Section: TPasSection); override; + procedure FinishTypeSection(El: TPasDeclarations); override; procedure FinishModule(CurModule: TPasModule); override; procedure FinishEnumType(El: TPasEnumType); override; procedure FinishSetType(El: TPasSetType); override; @@ -1117,6 +1119,7 @@ type procedure FinishArrayType(El: TPasArrayType); override; procedure FinishAncestors(aClass: TPasClassType); override; procedure FinishVariable(El: TPasVariable); override; + procedure FinishArgument(El: TPasArgument); override; procedure FinishProcedureType(El: TPasProcedureType); override; procedure FinishPropertyOfClass(PropEl: TPasProperty); override; procedure CheckConditionExpr(El: TPasExpr; @@ -2429,6 +2432,25 @@ begin end; end; +procedure TPas2JSResolver.FinishTypeSection(El: TPasDeclarations); +var + i: Integer; + Decl: TPasElement; + C: TClass; +begin + inherited FinishTypeSection(El); + for i:=0 to El.Declarations.Count-1 do + begin + Decl:=TPasElement(El.Declarations[i]); + C:=Decl.ClassType; + if C=TPasPointerType then + begin + // ToDo: pointer of record + RaiseMsg(20180423105726,nNotSupportedX,sNotSupportedX,['pointer of '+TPasPointerType(Decl).DestType.Name],El); + end; + end; +end; + procedure TPas2JSResolver.FinishModule(CurModule: TPasModule); var ModuleClass: TClass; @@ -2786,19 +2808,40 @@ begin AddExternalPath(ExtName,El.ExportName); end; - if (El.VarType<>nil) and (El.Expr<>nil) then + if El.VarType<>nil then begin TypeEl:=ResolveAliasType(El.VarType); - if (TypeEl.ClassType=TPasRecordType) then + + if TypeEl.ClassType=TPasPointerType then + RaiseMsg(20180423110113,nNotSupportedX,sNotSupportedX,['pointer'],El); + + if El.Expr<>nil then begin - if GetAssignGUIDString(TPasRecordType(TypeEl),El.Expr,GUID) then - // e.g. IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}' - else - ; + if (TypeEl.ClassType=TPasRecordType) then + begin + if GetAssignGUIDString(TPasRecordType(TypeEl),El.Expr,GUID) then + // e.g. IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}' + else + ; + end; end; end; end; +procedure TPas2JSResolver.FinishArgument(El: TPasArgument); +var + TypeEl: TPasType; +begin + inherited FinishArgument(El); + if El.ArgType<>nil then + begin + TypeEl:=ResolveAliasType(El.ArgType); + + if TypeEl.ClassType=TPasPointerType then + RaiseMsg(20180423110239,nNotSupportedX,sNotSupportedX,['pointer'],El); + end; +end; + procedure TPas2JSResolver.FinishProcedureType(El: TPasProcedureType); var Proc: TPasProcedure; @@ -2808,8 +2851,17 @@ var AClass: TPasClassType; ClassScope: TPas2JSClassScope; ptm: TProcTypeModifier; + TypeEl: TPasType; begin inherited FinishProcedureType(El); + + if El is TPasFunctionType then + begin + TypeEl:=ResolveAliasType(TPasFunctionType(El).ResultEl.ResultType); + if TypeEl.ClassType=TPasPointerType then + RaiseMsg(20180423110824,nNotSupportedX,sNotSupportedX,['pointer'],El); + end; + if El.Parent is TPasProcedure then begin Proc:=TPasProcedure(El.Parent); @@ -2964,7 +3016,6 @@ begin if Proc.Parent is TPasSection then AddExternalPath(ExtName,Proc.LibrarySymbolName); - exit; end; end; end; @@ -4848,9 +4899,18 @@ function TPasToJSConverter.ConvertUnaryExpression(El: TUnaryExpr; AContext: TConvertContext): TJSElement; procedure NotSupported; + var + ResolvedEl: TPasResolverResult; begin - DoError(20170215134950,nUnaryOpcodeNotSupported,sUnaryOpcodeNotSupported, - [OpcodeStrings[El.OpCode]],El); + if AContext.Resolver<>nil then + begin + AContext.Resolver.ComputeElement(El.Operand,ResolvedEl,[],El); + DoError(20180423111325,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf, + [OpcodeStrings[El.OpCode],AContext.Resolver.GetResolverResultDescription(ResolvedEl)],El); + end + else + DoError(20170215134950,nUnaryOpcodeNotSupported,sUnaryOpcodeNotSupported, + [OpcodeStrings[El.OpCode]],El); end; Var @@ -5348,6 +5408,8 @@ begin {$ENDIF} Result:=nil; aResolver:=AContext.Resolver; + LeftTypeEl:=aResolver.ResolveAliasType(LeftResolved.TypeEl); + RightTypeEl:=aResolver.ResolveAliasType(RightResolved.TypeEl); if LeftResolved.BaseType=btSet then begin // set operators -> rtl.operatorfunction(a,b) @@ -5462,11 +5524,25 @@ begin RaiseNotSupported(El,AContext,20180422104215); end; end + else if (LeftResolved.BaseType=btPointer) + or ((LeftResolved.BaseType=btContext) and (LeftTypeEl.ClassType=TPasPointerType)) then + case El.OpCode of + eopEqual,eopNotEqual: ; + else + DoError(20180423114054,nIllegalQualifierAfter,sIllegalQualifierAfter, + [OpcodeStrings[El.OpCode],aResolver.GetResolverResultDescription(LeftResolved,true)],El); + end + else if (RightResolved.BaseType=btPointer) + or ((RightResolved.BaseType=btContext) and (RightTypeEl.ClassType=TPasPointerType)) then + case El.OpCode of + eopEqual,eopNotEqual: ; + else + DoError(20180423114246,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf, + [OpcodeStrings[El.OpCode],aResolver.GetResolverResultDescription(RightResolved,true)],El); + end else if (El.OpCode=eopIs) then begin // "A is B" - LeftTypeEl:=aResolver.ResolveAliasType(LeftResolved.TypeEl); - RightTypeEl:=aResolver.ResolveAliasType(RightResolved.TypeEl); Call:=CreateCallExpression(El); Result:=Call; Call.AddArg(A); A:=nil; @@ -6454,6 +6530,12 @@ function TPasToJSConverter.ConvertArrayParams(El: TParamsExpr; var ArgContext: TConvertContext; + procedure RaiseIllegalBrackets(id: int64; const ResolvedEl: TPasResolverResult); + begin + DoError(id,nIllegalQualifierAfter,sIllegalQualifierAfter, + ['[',AContext.Resolver.GetResolverResultDescription(ResolvedEl,true)],El); + end; + function GetValueReference: TResolvedReference; var Value: TPasExpr; @@ -7118,10 +7200,10 @@ begin // anArray[] ConvertArray(TPasArrayType(TypeEl)) else - RaiseNotSupported(El,AContext,20170206181220,GetResolverResultDbg(ResolvedEl)); + RaiseIllegalBrackets(20170206181220,ResolvedEl); end else - RaiseNotSupported(El,AContext,20170206180222); + RaiseIllegalBrackets(20170206180222,ResolvedEl); end; function TPasToJSConverter.ConvertFuncParams(El: TParamsExpr; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 65af0ad53a..652670eb4a 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -538,8 +538,15 @@ type Procedure TestPointer_Proc; Procedure TestPointer_AssignRecordFail; Procedure TestPointer_AssignStaticArrayFail; - Procedure TestPointer_ArrayParamsFail; Procedure TestPointer_TypeCastJSValueToPointer; + Procedure TestPointer_NonRecordFail; + Procedure TestPointer_AnonymousArgTypeFail; + Procedure TestPointer_AnonymousVarTypeFail; + Procedure TestPointer_AnonymousResultTypeFail; + Procedure TestPointer_AddrOperatorFail; + Procedure TestPointer_ArrayParamsFail; + Procedure TestPointer_PointerAddFail; + Procedure TestPointer_IncPointerFail; // jsvalue Procedure TestJSValue_AssignToJSValue; @@ -16195,17 +16202,6 @@ begin ConvertProgram; end; -procedure TTestModule.TestPointer_ArrayParamsFail; -begin - StartProgram(false); - Add('var'); - Add(' p: Pointer;'); - Add('begin'); - Add(' p:=p[1];'); - SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter); - ConvertProgram; -end; - procedure TTestModule.TestPointer_TypeCastJSValueToPointer; begin StartProgram(false); @@ -16233,6 +16229,103 @@ begin ''])); end; +procedure TTestModule.TestPointer_NonRecordFail; +begin + StartProgram(false); + Add([ + 'type', + ' p = ^longint;', + 'begin', + '']); + SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_AnonymousArgTypeFail; +begin + StartProgram(false); + Add([ + 'procedure DoIt(p: ^longint); begin end;', + 'begin', + '']); + SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_AnonymousVarTypeFail; +begin + StartProgram(false); + Add([ + 'var p: ^longint;', + 'begin', + '']); + SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_AnonymousResultTypeFail; +begin + StartProgram(false); + Add([ + 'function DoIt: ^longint; begin end;', + 'begin', + '']); + SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_AddrOperatorFail; +begin + StartProgram(false); + Add([ + 'var i: longint;', + 'begin', + ' if @i=nil then ;', + '']); + SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_ArrayParamsFail; +begin + StartProgram(false); + Add([ + 'var', + ' p: Pointer;', + 'begin', + ' p:=p[1];', + '']); + SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_PointerAddFail; +begin + StartProgram(false); + Add([ + 'var', + ' p: Pointer;', + 'begin', + ' p:=p+1;', + '']); + SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB); + ConvertProgram; +end; + +procedure TTestModule.TestPointer_IncPointerFail; +begin + StartProgram(false); + Add([ + 'var', + ' p: Pointer;', + 'begin', + ' inc(p,1);', + '']); + SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"', + nIncompatibleTypeArgNo); + ConvertProgram; +end; + procedure TTestModule.TestJSValue_AssignToJSValue; begin StartProgram(false);