diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 30069a7954..151516db7b 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -109,6 +109,7 @@ Works: - external vars and methods - const - bracket accessor, getter/setter has external name '[]' + - TObject.Free sets variable to nil - dynamic arrays - arrays can be null - init as "arr = []" so typeof works @@ -247,13 +248,6 @@ Works: - dotted unit names, namespaces ToDos: -- scanner: bark on unknown modeswitch -- scanner: bark on disabling fixed modeswitch -- scanner: bark on unknown mode -- $hint -- $note -- $warn - - constant evaluation - integer ranges - static arrays @@ -266,7 +260,6 @@ ToDos: - documentation - move local types to unit scope - local var absolute -- make -Jirtl.js default for -Jc and -Tnodejs, needs #IFDEF in cfg - FuncName:= (instead of Result:=) - check memleaks - @@ compare method in delphi mode @@ -360,6 +353,7 @@ const nTypeXCannotBePublished = 4021; nNotSupportedX = 4022; nNestedInheritedNeedsParameters = 4023; + nFreeNeedsVar = 4024; // resourcestring patterns of messages resourcestring sPasElementNotSupported = 'Pascal element not supported: %s'; @@ -385,6 +379,7 @@ resourcestring sTypeXCannotBePublished = 'Type "%s" cannot be published'; sNotSupportedX = 'Not supported: %s'; sNestedInheritedNeedsParameters = 'nested inherited needs parameters'; + sFreeNeedsVar = 'Free needs a variable'; const ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter @@ -407,6 +402,8 @@ type pbifnGetObject, pbifnIs, pbifnIsExt, + pbifnFreeLocalVar, + pbifnFreeVar, pbifnProcType_Create, pbifnProcType_Equal, pbifnProgramMain, @@ -467,6 +464,7 @@ type pbivnRTTIPropStored, pbivnRTTISet_CompType, pbivnSelf, + pbivnTObjectDestroy, pbivnWith, pbitnAnonymousPostfix, pbitnIntDouble, @@ -504,6 +502,8 @@ const 'getObject', // rtl.getObject 'is', // rtl.is 'isExt', // rtl.isExt + 'freeLoc', // rtl.freeLoc + 'free', // rtl.free 'createCallback', // rtl.createCallback 'eqCallback', // rtl.eqCallback '$main', @@ -539,7 +539,7 @@ const 'symDiffSet', // rtl.symDiffSet >< (symmetrical difference) 'unionSet', // rtl.unionSet + 'spaceLeft', // rtl.spaceLeft - 'strSetLength', + 'strSetLength', // rtl. '$init', '$e', '$impl', @@ -564,22 +564,23 @@ const 'stored', 'comptype', 'Self', + 'tObjectDestroy', // rtl.tObjectDestroy '$with', '$a', 'NativeInt', - 'tTypeInfo', - 'tTypeInfoClass', - 'tTypeInfoClassRef', - 'tTypeInfoDynArray', - 'tTypeInfoEnum', - 'tTypeInfoInteger', - 'tTypeInfoMethodVar', - 'tTypeInfoPointer', - 'tTypeInfoProcVar', - 'tTypeInfoRecord', - 'tTypeInfoRefToProcVar', - 'tTypeInfoSet', - 'tTypeInfoStaticArray', + 'tTypeInfo', // rtl. + 'tTypeInfoClass', // rtl. + 'tTypeInfoClassRef', // rtl. + 'tTypeInfoDynArray', // rtl. + 'tTypeInfoEnum', // rtl. + 'tTypeInfoInteger', // rtl. + 'tTypeInfoMethodVar', // rtl. + 'tTypeInfoPointer', // rtl. + 'tTypeInfoProcVar', // rtl. + 'tTypeInfoRecord', // rtl. + 'tTypeInfoRefToProcVar', // rtl. + 'tTypeInfoSet', // rtl. + 'tTypeInfoStaticArray', // rtl. 'NativeUInt' ); @@ -875,6 +876,8 @@ type procedure PushOverloadScope(Scope: TPasIdentifierScope); procedure PopOverloadScope; procedure ResolveImplAsm(El: TPasImplAsmStatement); override; + procedure ResolveNameExpr(El: TPasExpr; const aName: string; + Access: TResolvedRefAccess); override; procedure FinishModule(CurModule: TPasModule); override; procedure FinishSetType(El: TPasSetType); override; procedure FinishClassType(El: TPasClassType); override; @@ -932,6 +935,7 @@ type function GetBaseDescription(const R: TPasResolverResult; AddPath: boolean= false): string; override; function HasTypeInfo(El: TPasType): boolean; override; + function IsTObjectFreeMethod(El: TPasExpr): boolean; virtual; end; //------------------------------------------------------------------------------ @@ -1129,11 +1133,11 @@ type FPreservedWords: TJSReservedWordList; // sorted with CompareStr FTargetPlatform: TPasToJsPlatform; FTargetProcessor: TPasToJsProcessor; - Function CreateBuiltInIdentifierExpr(AName: string): TJSPrimaryExpressionIdent; + Function CreatePrimitiveDotExpr(AName: string; Src: TPasElement = nil): TJSElement; Function CreateSubDeclNameExpr(El: TPasElement; const Name: string; - AContext: TConvertContext): TJSPrimaryExpressionIdent; - Function CreateIdentifierExpr(El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent; - Function CreateIdentifierExpr(AName: string; El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent; + AContext: TConvertContext): TJSElement; + Function CreateIdentifierExpr(El: TPasElement; AContext: TConvertContext): TJSElement; + Function CreateIdentifierExpr(AName: string; El: TPasElement; AContext: TConvertContext): TJSElement; Function CreateSwitchStatement(El: TPasImplCaseOf; AContext: TConvertContext): TJSElement; Function CreateTypeDecl(El: TPasType; AContext: TConvertContext): TJSElement; Function CreateVarDecl(El: TPasVariable; AContext: TConvertContext): TJSElement; @@ -1204,6 +1208,7 @@ type Function CreateLiteralNull(El: TPasElement): TJSLiteral; virtual; Function CreateLiteralUndefined(El: TPasElement): TJSLiteral; virtual; Function CreateSetLiteralElement(Expr: TPasExpr; AContext: TConvertContext): TJSElement; virtual; + Function ClonePrimaryExpression(El: TJSPrimaryExpression; Src: TPasElement): TJSPrimaryExpression; Function CreateRecordInit(aRecord: TPasRecordType; Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement; virtual; Function CreateArrayInit(ArrayType: TPasArrayType; Expr: TPasElement; @@ -1213,7 +1218,7 @@ type Function CreateReferencePath(El: TPasElement; AContext : TConvertContext; Kind: TRefPathKind; Full: boolean = false; Ref: TResolvedReference = nil): string; virtual; Function CreateReferencePathExpr(El: TPasElement; AContext : TConvertContext; - Full: boolean = false; Ref: TResolvedReference = nil): TJSPrimaryExpressionIdent; virtual; + Full: boolean = false; Ref: TResolvedReference = nil): TJSElement; virtual; Function CreateImplementationSection(El: TPasModule; AContext: TConvertContext): TJSFunctionDeclarationStatement; Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); Function CreateDotExpression(aParent: TPasElement; Left, Right: TJSElement): TJSElement; virtual; @@ -1259,9 +1264,9 @@ type Function ConvertParamsExpression(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertArrayParams(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertFuncParams(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; - Function ConvertExternalConstructor(Left: TPasElement; - Ref: TResolvedReference; ParamsExpr: TParamsExpr; - AContext : TConvertContext): TJSElement; virtual; + Function ConvertExternalConstructor(Left: TPasElement; Ref: TResolvedReference; + ParamsExpr: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; + Function ConvertTObjectFree(Bin: TBinaryExpr; NameExpr: TPasExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertTypeCastToBaseType(El: TParamsExpr; AContext: TConvertContext; ToBaseTypeData: TResElDataBaseType): TJSElement; virtual; Function ConvertSetLiteral(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertOpenArrayParam(ElType: TPasType; El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; @@ -1829,6 +1834,78 @@ begin if Lines=nil then exit; end; +procedure TPas2JSResolver.ResolveNameExpr(El: TPasExpr; const aName: string; + Access: TResolvedRefAccess); + + procedure CheckTObjectFree(Ref: TResolvedReference); + var + Bin: TBinaryExpr; + Left: TPasExpr; + LeftResolved: TPasResolverResult; + IdentEl: TPasElement; + begin + if not IsTObjectFreeMethod(El) then exit; + if Ref.WithExprScope<>nil then + begin + // with expr do free + if GetNewInstanceExpr(Ref.WithExprScope.Expr)<>nil then + exit; // with TSomeClass.Free do Free -> ok + RaiseMsg(20170517092407,nFreeNeedsVar,sFreeNeedsVar,[],El); + end; + if (El.Parent.ClassType<>TBinaryExpr) then + RaiseMsg(20170516151916,nFreeNeedsVar,sFreeNeedsVar,[],El); + Bin:=TBinaryExpr(El.Parent); + if (Bin.right<>El) or (Bin.OpCode<>eopSubIdent) then + RaiseMsg(20170516151950,nFreeNeedsVar,sFreeNeedsVar,[],El); + if rrfImplicitCallWithoutParams in Ref.Flags then + // ".Free;" -> ok + else if Bin.Parent is TParamsExpr then + begin + if Bin.Parent.Parent is TPasExpr then + RaiseMsg(20170516161345,nFreeNeedsVar,sFreeNeedsVar,[],El); + // ".Free();" -> ok + end + else if Bin.Parent is TPasImplElement then + // ok + else + begin + {$IFDEF VerbosePas2JS} + writeln('TPas2JSResolver.ResolveNameExpr.CheckTObjectFree Bin.Parent=',GetObjName(Bin.Parent)); + {$ENDIF} + RaiseMsg(20170516160347,nFreeNeedsVar,sFreeNeedsVar,[],El); + end; + + Left:=Bin.left; + ComputeElement(Left,LeftResolved,[]); + if not (rrfReadable in LeftResolved.Flags) then + RaiseMsg(20170516152300,nFreeNeedsVar,sFreeNeedsVar,[],El); + if not (rrfWritable in LeftResolved.Flags) then + RaiseMsg(20170516152307,nFreeNeedsVar,sFreeNeedsVar,[],El); + IdentEl:=LeftResolved.IdentEl; + if IdentEl=nil then + RaiseMsg(20170516152401,nFreeNeedsVar,sFreeNeedsVar,[],El); + if IdentEl.ClassType=TPasArgument then + exit; // readable and writable argument -> ok + if (IdentEl.ClassType=TPasVariable) + or (IdentEl.ClassType=TPasConst) then + exit; // readable and writable variable -> ok + if IdentEl.ClassType=TPasResultElement then + exit; // readable and writable function result -> ok + RaiseMsg(20170516152455,nFreeNeedsVar,sFreeNeedsVar,[],El); + end; + +var + Ref: TResolvedReference; +begin + inherited ResolveNameExpr(El, aName, Access); + if El.CustomData is TResolvedReference then + begin + Ref:=TResolvedReference(El.CustomData); + if (CompareText(aName,'free')=0) then + CheckTObjectFree(Ref); + end; +end; + procedure TPas2JSResolver.FinishModule(CurModule: TPasModule); var ModuleClass: TClass; @@ -2995,6 +3072,27 @@ begin Result:=false; end; +function TPas2JSResolver.IsTObjectFreeMethod(El: TPasExpr): boolean; +var + Ref: TResolvedReference; + Decl: TPasElement; +begin + Result:=false; + if El=nil then exit; + if El.ClassType<>TPrimitiveExpr then exit; + if not (El.CustomData is TResolvedReference) then exit; + Ref:=TResolvedReference(El.CustomData); + if CompareText(TPrimitiveExpr(El).Value,'free')<>0 then exit; + Decl:=Ref.Declaration; + if not (Decl.ClassType=TPasProcedure) + or (Decl.Parent.ClassType<>TPasClassType) + or (CompareText(Decl.Parent.Name,'tobject')<>0) + or (pmExternal in TPasProcedure(Decl).Modifiers) + or (TPasProcedure(Decl).ProcType.Args.Count>0) then + exit; + Result:=true; +end; + { TP2JConstExprData } destructor TP2JConstExprData.Destroy; @@ -3481,7 +3579,7 @@ begin ModVarName:=FBuiltInNames[pbivnModule]; IntfContext.AddLocalVar(ModVarName,El); AddToSourceElements(Src,CreateVarStatement(ModVarName, - CreateBuiltInIdentifierExpr('this'),El)); + CreatePrimitiveDotExpr('this'),El)); if (El is TPasProgram) then begin // program @@ -3596,7 +3694,7 @@ begin else FunName:=FBuiltInNames[pbifnClassInstanceFree]; FunName:=CreateReferencePath(Proc,AContext,rpkPathWithDot,false,Ref)+FunName; - C.Expr:=CreateBuiltInIdentifierExpr(FunName); + C.Expr:=CreatePrimitiveDotExpr(FunName); ArgElems:=C.Args.Elements; // parameter: "funcname" ArgEx := CreateLiteralString(Ref.Element,TransformVariableName(Proc,AContext)); @@ -3975,10 +4073,10 @@ begin Call:=CreateCallExpression(El); if (RightResolved.TypeEl is TPasClassType) and TPasClassType(RightResolved.TypeEl).IsExternal then // B is external class -> "rtl.asExt(A,B)" - Call.Expr:=CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnAsExt]) + Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnAsExt]) else // otherwise -> "rtl.as(A,B)" - Call.Expr:=CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnAs]); + Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnAs]); Call.AddArg(A); Call.AddArg(B); Result:=Call; @@ -4011,7 +4109,7 @@ begin eopPower: begin Call:=CreateCallExpression(El); - Call.Expr:=CreateBuiltInIdentifierExpr('Math.pow'); + Call.Expr:=CreatePrimitiveDotExpr('Math.pow'); Call.AddArg(A); Call.AddArg(B); Result:=Call; @@ -4032,7 +4130,7 @@ begin // convert "a div b" to "Math.floor(a/b)" Call:=CreateCallExpression(El); Call.AddArg(R); - Call.Expr:=CreateBuiltInIdentifierExpr('Math.floor'); + Call.Expr:=CreatePrimitiveDotExpr('Math.floor'); Result:=Call; end; end; @@ -4176,7 +4274,7 @@ begin begin // convert "recordA = recordB" to "recordA.$equal(recordB)" Call:=CreateCallExpression(El); - Call.Expr:=CreateDotExpression(El,A,CreateBuiltInIdentifierExpr(FBuiltInNames[pbifnRecordEqual])); + Call.Expr:=CreateDotExpression(El,A,CreatePrimitiveDotExpr(FBuiltInNames[pbifnRecordEqual])); A:=nil; Call.AddArg(B); B:=nil; @@ -4230,7 +4328,7 @@ var begin Result:=nil; - ParamsExpr:=nil;; + ParamsExpr:=nil; RightEl:=El.right; while RightEl.ClassType=TParamsExpr do begin @@ -4252,6 +4350,11 @@ begin else Result:=ConvertExternalConstructor(El.left,RightRef,nil,AContext); exit; + end + else if AContext.Resolver.IsTObjectFreeMethod(RightEl) then + begin + Result:=ConvertTObjectFree(El,RightEl,AContext); + exit; end; end; @@ -4289,28 +4392,19 @@ begin end; function TPasToJSConverter.CreateIdentifierExpr(El: TPasElement; - AContext: TConvertContext): TJSPrimaryExpressionIdent; -var - I: TJSPrimaryExpressionIdent; + AContext: TConvertContext): TJSElement; begin - I:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El)); - I.Name:=TJSString(TransformVariableName(El,AContext)); - Result:=I; + Result:=CreatePrimitiveDotExpr(TransformVariableName(El,AContext),El); end; function TPasToJSConverter.CreateIdentifierExpr(AName: string; El: TPasElement; - AContext: TConvertContext): TJSPrimaryExpressionIdent; -Var - I : TJSPrimaryExpressionIdent; + AContext: TConvertContext): TJSElement; begin - I:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El)); - AName:=TransformVariableName(El,AName,AContext); - I.Name:=TJSString(AName); - Result:=I; + Result:=CreatePrimitiveDotExpr(TransformVariableName(El,AName,AContext),El); end; function TPasToJSConverter.CreateSubDeclNameExpr(El: TPasElement; - const Name: string; AContext: TConvertContext): TJSPrimaryExpressionIdent; + const Name: string; AContext: TConvertContext): TJSElement; var CurName, ParentName: String; begin @@ -4319,8 +4413,7 @@ begin if ParentName='' then ParentName:='this'; CurName:=ParentName+'.'+CurName; - Result:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El)); - Result.Name:=TJSString(CurName); + Result:=CreatePrimitiveDotExpr(CurName,El); end; function TPasToJSConverter.ConvertPrimitiveExpression(El: TPrimitiveExpr; @@ -4451,6 +4544,12 @@ begin exit; end; + if (Ref.WithExprScope<>nil) and AContext.Resolver.IsTObjectFreeMethod(El) then + begin + Result:=ConvertTObjectFree(nil,El,AContext); + exit; + end; + Prop:=nil; AssignContext:=nil; ImplicitCall:=rrfImplicitCallWithoutParams in Ref.Flags; @@ -4503,7 +4602,7 @@ begin Call:=CreateCallExpression(El); Call.Expr:=CreateDotExpression(El, CreateIdentifierExpr(Arg.Name,Arg,AContext), - CreateBuiltInIdentifierExpr(TempRefObjGetterName)); + CreatePrimitiveDotExpr(TempRefObjGetterName)); Result:=Call; exit; end; @@ -4517,7 +4616,7 @@ begin AssignContext.Call:=Call; Call.Expr:=CreateDotExpression(El, CreateIdentifierExpr(Arg.Name,Arg,AContext), - CreateBuiltInIdentifierExpr(TempRefObjSetterName)); + CreatePrimitiveDotExpr(TempRefObjSetterName)); Call.AddArg(AssignContext.RightSide); AssignContext.RightSide:=nil; Result:=Call; @@ -4587,7 +4686,7 @@ begin else Name:=CreateReferencePath(Decl,AContext,rpkPathAndName,false,Ref); if Result=nil then - Result:=CreateBuiltInIdentifierExpr(Name); + Result:=CreatePrimitiveDotExpr(Name); if ImplicitCall then begin @@ -4681,11 +4780,11 @@ function TPasToJSConverter.ConvertInheritedExpression(El: TInheritedExpr; Call:=nil; try Call:=CreateCallExpression(ParentEl); - Call.Expr:=CreateBuiltInIdentifierExpr(FunName); - Call.AddArg(CreateBuiltInIdentifierExpr(SelfName)); + Call.Expr:=CreatePrimitiveDotExpr(FunName); + Call.AddArg(CreatePrimitiveDotExpr(SelfName)); if Apply then // "inherited;" -> pass the arguments - Call.AddArg(CreateBuiltInIdentifierExpr('arguments')) + Call.AddArg(CreatePrimitiveDotExpr('arguments')) else // "inherited Name(...)" -> pass the user arguments CreateProcedureCall(Call,ParamsExpr,AncestorProc.ProcType,AContext); @@ -4999,7 +5098,7 @@ var Ref:=TResolvedReference(PathEl.CustomData); Path:=CreateReferencePath(Prop,AContext,rpkPath,false,Ref); if Path<>'' then - Bracket.MExpr:=CreateBuiltInIdentifierExpr(Path); + Bracket.MExpr:=CreatePrimitiveDotExpr(Path); PathEl:=nil; end else if (PathEl is TBinaryExpr) @@ -5515,7 +5614,7 @@ begin else // use external class name ExtName:=(Proc.Parent as TPasClassType).ExternalName; - ExtNameEl:=CreateBuiltInIdentifierExpr(ExtName); + ExtNameEl:=CreatePrimitiveDotExpr(ExtName); end; if CompareText(Proc.Name,'new')=0 then @@ -5539,6 +5638,112 @@ begin end; end; +function TPasToJSConverter.ConvertTObjectFree(Bin: TBinaryExpr; + NameExpr: TPasExpr; AContext: TConvertContext): TJSElement; + + function CreateCallRTLFree(Obj, Prop: TJSElement): TJSElement; + // create "rtl.free(obj,prop)" + var + Call: TJSCallExpression; + begin + Call:=CreateCallExpression(Bin.right); + Call.Expr:=CreateMemberExpression([GetBuildInNames(pbivnRTL),GetBuildInNames(pbifnFreeVar)]); + Call.Args.AddElement(Obj); + Call.Args.AddElement(Prop); + Result:=Call; + end; + + function CreateCallRTLFreeLoc(Setter, Getter: TJSElement; Src: TPasElement): TJSElement; + // create "Setter=rtl.freeLoc(Getter)" + var + Call: TJSCallExpression; + AssignSt: TJSSimpleAssignStatement; + begin + Call:=CreateCallExpression(Src); + Call.Expr:=CreateMemberExpression([GetBuildInNames(pbivnRTL),GetBuildInNames(pbifnFreeLocalVar)]); + Call.Args.AddElement(Getter); + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,Src)); + AssignSt.LHS:=Setter; + AssignSt.Expr:=Call; + Result:=AssignSt; + end; + +var + LeftJS, Obj, Prop, Getter, Setter: TJSElement; + DotExpr: TJSDotMemberExpression; + BracketJS: TJSBracketMemberExpression; + aName: TJSString; + WithExprScope: TPas2JSWithExprScope; +begin + Result:=nil; + + LeftJS:=nil; + try + WithExprScope:=TResolvedReference(NameExpr.CustomData).WithExprScope as TPas2JSWithExprScope; + if WithExprScope<>nil then + begin + if AContext.Resolver.GetNewInstanceExpr(WithExprScope.Expr)<>nil then + begin + // "with TSomeClass.Create do Free" + // -> "$with1=rtl.freeLoc($with1); + Getter:=CreatePrimitiveDotExpr(WithExprScope.WithVarName,WithExprScope.Expr); + Setter:=CreatePrimitiveDotExpr(WithExprScope.WithVarName,WithExprScope.Expr); + Result:=CreateCallRTLFreeLoc(Setter,Getter,NameExpr); + exit; + end; + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertTObjectFree With=',GetObjName(WithExprScope.Expr)); + {$ENDIF} + RaiseInconsistency(20170517092248); + end; + + LeftJS:=ConvertElement(Bin.left,AContext); + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertTObjectFree ',GetObjName(LeftJS)); + {$ENDIF} + + if LeftJS is TJSPrimaryExpressionIdent then + begin + aName:=TJSPrimaryExpressionIdent(LeftJS).Name; + if Pos('.',aName)>0 then + RaiseInconsistency(20170516173832); + // v.free + // -> v=rtl.freeLoc(v); + Getter:=LeftJS; + Setter:=ClonePrimaryExpression(TJSPrimaryExpressionIdent(LeftJS),Bin.left); + Result:=CreateCallRTLFreeLoc(Setter,Getter,NameExpr); + end + else if LeftJS is TJSDotMemberExpression then + begin + // obj.prop.free + // -> rtl.free(obj,"prop"); + DotExpr:=TJSDotMemberExpression(LeftJS); + Obj:=DotExpr.MExpr; + DotExpr.MExpr:=nil; + Prop:=CreateLiteralJSString(Bin.right,DotExpr.Name); + FreeAndNil(LeftJS); + Result:=CreateCallRTLFree(Obj,Prop); + end + else if LeftJS is TJSBracketMemberExpression then + begin + // obj[prop].free + // -> rtl.free(obj,prop); + BracketJS:=TJSBracketMemberExpression(LeftJS); + Obj:=BracketJS.MExpr; + BracketJS.MExpr:=nil; + Prop:=BracketJS.Name; + BracketJS.Name:=nil; + FreeAndNil(LeftJS); + Result:=CreateCallRTLFree(Obj,Prop); + end + else + RaiseNotSupported(Bin.left,AContext,20170516164659,'invalid scope for Free'); + finally + if Result=nil then + LeftJS.Free; + end; +end; + function TPasToJSConverter.ConvertTypeCastToBaseType(El: TParamsExpr; AContext: TConvertContext; ToBaseTypeData: TResElDataBaseType): TJSElement; var @@ -5898,7 +6103,7 @@ begin // default: Param.length Arg:=ConvertElement(Param,AContext); - Result:=CreateDotExpression(El,Arg,CreateBuiltInIdentifierExpr('length')); + Result:=CreateDotExpression(El,Arg,CreatePrimitiveDotExpr('length')); end; function TPasToJSConverter.ConvertBuiltIn_SetLength(El: TParamsExpr; @@ -6056,7 +6261,7 @@ begin ProcEl:=ProcEl.Parent; if ProcEl is TPasFunction then // in a function, "return result;" - TJSReturnStatement(Result).Expr:=CreateBuiltInIdentifierExpr(ResolverResultVar) + TJSReturnStatement(Result).Expr:=CreatePrimitiveDotExpr(ResolverResultVar) else ; // in a procedure, "return;" which means "return undefined;" end; @@ -6112,7 +6317,7 @@ begin // create "ref.set" Call.Expr:=CreateDotExpression(El, CreateIdentifierExpr(ExprResolved.IdentEl,AContext), - CreateBuiltInIdentifierExpr(TempRefObjSetterName)); + CreatePrimitiveDotExpr(TempRefObjSetterName)); // create "+" if IsInc then AddJS:=TJSAdditiveExpressionPlus(CreateElement(TJSAdditiveExpressionPlus,El)) @@ -6123,7 +6328,7 @@ begin AddJS.A:=TJSCallExpression(CreateElement(TJSCallExpression,El)); TJSCallExpression(AddJS.A).Expr:=CreateDotExpression(El, CreateIdentifierExpr(ExprResolved.IdentEl,AContext), - CreateBuiltInIdentifierExpr(TempRefObjGetterName)); + CreatePrimitiveDotExpr(TempRefObjGetterName)); // add "b" AddJS.B:=ValueJS; ValueJS:=nil; @@ -6277,7 +6482,7 @@ begin Call:=nil; try Call:=CreateCallExpression(El); - Call.Expr:=CreateDotExpression(El,SubParamJS,CreateBuiltInIdentifierExpr('charCodeAt')); + Call.Expr:=CreateDotExpression(El,SubParamJS,CreatePrimitiveDotExpr('charCodeAt')); Minus:=TJSAdditiveExpressionMinus(CreateElement(TJSAdditiveExpressionMinus,Param)); Call.AddArg(Minus); if length(SubParams.Params)<>1 then @@ -6297,7 +6502,7 @@ begin Result:=ConvertElement(Param,AContext); // Note: convert Param first, as it might raise an exception Call:=CreateCallExpression(El); - Call.Expr:=CreateDotExpression(El,Result,CreateBuiltInIdentifierExpr('charCodeAt')); + Call.Expr:=CreateDotExpression(El,Result,CreatePrimitiveDotExpr('charCodeAt')); Result:=Call; exit; end @@ -6687,7 +6892,7 @@ begin // precision -> rtl El.toFixed(precision); NeedStrLit:=false; Call:=CreateCallExpression(El); - Call.Expr:=CreateDotExpression(El,Add,CreateBuiltInIdentifierExpr('toFixed')); + Call.Expr:=CreateDotExpression(El,Add,CreatePrimitiveDotExpr('toFixed')); Call.AddArg(ConvertElement(El.format2,AContext)); Add:=Call; Call:=nil; @@ -6793,7 +6998,7 @@ begin if Call.Expr=nil then // default: array1.concat(array2,...) Call.Expr:=CreateDotExpression(El,ConvertElement(Param0,AContext), - CreateBuiltInIdentifierExpr('concat')); + CreatePrimitiveDotExpr('concat')); for i:=1 to length(El.Params)-1 do Call.AddArg(ConvertElement(El.Params[i],AContext)); Result:=Call; @@ -6875,7 +7080,7 @@ begin try Call:=CreateCallExpression(El); ArrEl:=ConvertElement(El.Params[1],AContext); - Call.Expr:=CreateDotExpression(El,ArrEl,CreateBuiltInIdentifierExpr('splice')); + Call.Expr:=CreateDotExpression(El,ArrEl,CreatePrimitiveDotExpr('splice')); Call.AddArg(ConvertElement(El.Params[2],AContext)); Call.AddArg(CreateLiteralNumber(El,1)); Call.AddArg(ConvertElement(El.Params[0],AContext)); @@ -6899,7 +7104,7 @@ begin try Call:=CreateCallExpression(El); ArrEl:=ConvertElement(El.Params[0],AContext); - Call.Expr:=CreateDotExpression(El,ArrEl,CreateBuiltInIdentifierExpr('splice')); + Call.Expr:=CreateDotExpression(El,ArrEl,CreatePrimitiveDotExpr('splice')); Call.AddArg(ConvertElement(El.Params[1],AContext)); Call.AddArg(ConvertElement(El.Params[2],AContext)); Result:=Call; @@ -6949,7 +7154,7 @@ begin // typeinfo(classinstance) -> classinstance.$rtti // typeinfo(classof) -> classof.$rtti Result:=ConvertElement(Param,AContext); - Result:=CreateDotExpression(El,Result,CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnRTTI])); + Result:=CreateDotExpression(El,Result,CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTTI])); end else Result:=CreateTypeInfoRef(TypeEl,AContext,Param); @@ -7025,17 +7230,35 @@ begin RaiseNotSupported(El,AContext,20161024191314); end; -function TPasToJSConverter.CreateBuiltInIdentifierExpr(AName: string - ): TJSPrimaryExpressionIdent; +function TPasToJSConverter.CreatePrimitiveDotExpr(AName: string; + Src: TPasElement): TJSElement; var + p: Integer; + DotExpr: TJSDotMemberExpression; Ident: TJSPrimaryExpressionIdent; begin if AName='' then RaiseInconsistency(20170402230134); - Ident:=TJSPrimaryExpressionIdent.Create(0,0); - // do not lowercase - Ident.Name:=TJSString(AName); - Result:=Ident; + p:=PosLast('.',AName); + if p>0 then + begin + if Src<>nil then + DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,Src)) + else + DotExpr:=TJSDotMemberExpression.Create(0,0); + DotExpr.Name:=TJSString(copy(AName,p+1,length(AName))); // do not lowercase + DotExpr.MExpr:=CreatePrimitiveDotExpr(LeftStr(AName,p-1)); + Result:=DotExpr; + end + else + begin + if Src<>nil then + Ident:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,Src)) + else + Ident:=TJSPrimaryExpressionIdent.Create(0,0); + Ident.Name:=TJSString(AName); // do not lowercase + Result:=Ident; + end; end; function TPasToJSConverter.CreateTypeDecl(El: TPasType; @@ -7236,7 +7459,7 @@ Var RetSt: TJSReturnStatement; begin RetSt:=TJSReturnStatement(CreateElement(TJSReturnStatement,El)); - RetSt.Expr:=CreateBuiltInIdentifierExpr(ResolverResultVar); + RetSt.Expr:=CreatePrimitiveDotExpr(ResolverResultVar); Add(RetSt); end; @@ -7354,8 +7577,8 @@ var exit; Call:=CreateCallExpression(El); AncestorPath:=CreateReferencePath(Ancestor,ClassContext,rpkPathAndName); - Call.Expr:=CreateBuiltInIdentifierExpr(AncestorPath+'.'+MemberFuncName[Kind]+'.call'); - Call.AddArg(CreateBuiltInIdentifierExpr('this')); + Call.Expr:=CreatePrimitiveDotExpr(AncestorPath+'.'+MemberFuncName[Kind]+'.call'); + Call.AddArg(CreatePrimitiveDotExpr('this')); AddToSourceElements(Src,Call); end; @@ -7503,8 +7726,9 @@ var P: TPasElement; Scope: TPas2JSClassScope; Ancestor: TPasType; - AncestorPath, OwnerName: String; + AncestorPath, OwnerName, DestructorName: String; C: TClass; + AssignSt: TJSSimpleAssignStatement; begin Result:=nil; if El.IsForward then @@ -7544,7 +7768,7 @@ begin OwnerName:=AContext.GetLocalName(El.GetModule); if OwnerName='' then OwnerName:='this'; - Call.AddArg(CreateBuiltInIdentifierExpr(OwnerName)); + Call.AddArg(CreatePrimitiveDotExpr(OwnerName)); // add parameter: string constant '"classname"' ArgEx := CreateLiteralString(El,TransformVariableName(El,AContext)); @@ -7557,7 +7781,7 @@ begin AncestorPath:=TPasClassType(Ancestor).ExternalName else AncestorPath:=CreateReferencePath(Ancestor,AContext,rpkPathAndName); - Call.AddArg(CreateBuiltInIdentifierExpr(AncestorPath)); + Call.AddArg(CreatePrimitiveDotExpr(AncestorPath)); if AncestorIsExternal then begin @@ -7626,7 +7850,21 @@ begin //writeln('TPasToJSConverter.ConvertClassType methods El[',i,']=',GetObjName(P)); if not IsMemberNeeded(P) then continue; if P is TPasProcedure then - NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext) + begin + if IsTObject and (P.ClassType=TPasDestructor) then + begin + DestructorName:=TransformVariableName(P,AContext); + if DestructorName<>'Destroy' then + begin + // add 'rtl.tObjectDestroy="destroy";' + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,P)); + AssignSt.LHS:=CreateMemberExpression([GetBuildInNames(pbivnRTL),GetBuildInNames(pbivnTObjectDestroy)]); + AssignSt.Expr:=CreateLiteralString(P,DestructorName); + AddToSourceElements(Src,AssignSt); + end; + end; + NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext); + end else continue; if NewEl=nil then @@ -8224,7 +8462,7 @@ begin // has nested procs -> add "var self = this;" FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],FuncContext.ThisPas); SelfSt:=CreateVarStatement(FBuiltInNames[pbivnSelf], - CreateBuiltInIdentifierExpr('this'),El); + CreatePrimitiveDotExpr('this'),El); AddBodyStatement(SelfSt,BodyPas); if ImplProcScope.SelfArg<>nil then begin @@ -8400,7 +8638,7 @@ begin // default else: throw exceptobject Last.BFalse:=TJSThrowStatement(CreateElement(TJSThrowStatement,El)); TJSThrowStatement(Last.BFalse).A:= - CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnExceptObject]); + CreatePrimitiveDotExpr(FBuiltInNames[pbivnExceptObject]); end; end else @@ -8605,7 +8843,7 @@ begin ImplContext.ThisPas:=El; ModVarName:=FBuiltInNames[pbivnModule]; AddToSourceElements(Src,CreateVarStatement(ModVarName, - CreateBuiltInIdentifierExpr('this'),El)); + CreatePrimitiveDotExpr('this'),El)); ImplContext.AddLocalVar(ModVarName,El); // add var $impl = $mod.$impl @@ -8927,7 +9165,7 @@ begin if El is TPasClassType then begin // use this - Result:=CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnRTTILocal]); + Result:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTTILocal]); exit; end else @@ -9481,7 +9719,7 @@ begin if El.ExceptObject<>Nil then E:=ConvertElement(El.ExceptObject,AContext) else - E:=CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnExceptObject]); + E:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnExceptObject]); T:=TJSThrowStatement(CreateElement(TJSThrowStatement,El)); T.A:=E; Result:=T; @@ -9852,13 +10090,21 @@ function TPasToJSConverter.ConvertSimpleStatement(El: TPasImplSimple; Var E : TJSElement; + C: TClass; begin E:=ConvertElement(EL.Expr,AContext); if E=nil then exit(nil); // e.g. "inherited;" without ancestor proc - Result:=TJSExpressionStatement(CreateElement(TJSExpressionStatement,El)); - TJSExpressionStatement(Result).A:=E; + C:=E.ClassType; + if (C=TJSExpressionStatement) + or (C=TJSStatementList) then + Result:=E + else + begin + Result:=TJSExpressionStatement(CreateElement(TJSExpressionStatement,El)); + TJSExpressionStatement(Result).A:=E; + end; end; function TPasToJSConverter.ConvertWithStatement(El: TPasImplWithDo; @@ -10403,7 +10649,7 @@ begin begin // aChar -> aChar.charCodeAt() Call:=TJSCallExpression(CreateElement(TJSCallExpression,Expr)); - Call.Expr:=CreateDotExpression(Expr,Result,CreateBuiltInIdentifierExpr('charCodeAt')); + Call.Expr:=CreateDotExpression(Expr,Result,CreatePrimitiveDotExpr('charCodeAt')); Result:=Call; end else if ExprResolved.BaseType=btContext then @@ -10418,6 +10664,14 @@ begin end; end; +function TPasToJSConverter.ClonePrimaryExpression(El: TJSPrimaryExpression; + Src: TPasElement): TJSPrimaryExpression; +begin + Result:=TJSPrimaryExpression(CreateElement(TJSElementClass(El.ClassType),Src)); + if Result.ClassType=TJSPrimaryExpressionIdent then + TJSPrimaryExpressionIdent(Result).Name:=TJSPrimaryExpressionIdent(El).Name; +end; + function TPasToJSConverter.CreateRecordInit(aRecord: TPasRecordType; Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement; // new recordtype() @@ -10780,7 +11034,7 @@ end; function TPasToJSConverter.CreateReferencePathExpr(El: TPasElement; AContext: TConvertContext; Full: boolean; Ref: TResolvedReference - ): TJSPrimaryExpressionIdent; + ): TJSElement; var Name: String; begin @@ -10788,7 +11042,7 @@ begin writeln('TPasToJSConverter.CreateReferencePathExpr El="',GetObjName(El),'" El.Parent=',GetObjName(El.Parent)); {$ENDIF} Name:=CreateReferencePath(El,AContext,rpkPathAndName,Full,Ref); - Result:=CreateBuiltInIdentifierExpr(Name); + Result:=CreatePrimitiveDotExpr(Name); end; procedure TPasToJSConverter.CreateProcedureCall(var Call: TJSCallExpression; @@ -11036,12 +11290,12 @@ begin // GetExpr: this.p.readvar // Will create "{p:GetPathExpr, get:function(){return GetExpr;}, // set:function(v){GetExpr = v;}}" - GetPathExpr:=CreateBuiltInIdentifierExpr(LeftStr(GetPath,GetDotPos-1)); - GetExpr:=CreateDotExpression(El,CreateBuiltInIdentifierExpr('this.'+GetPathName), - CreateBuiltInIdentifierExpr(copy(GetPath,GetDotPos+1))); + GetPathExpr:=CreatePrimitiveDotExpr(LeftStr(GetPath,GetDotPos-1)); + GetExpr:=CreateDotExpression(El,CreatePrimitiveDotExpr('this.'+GetPathName), + CreatePrimitiveDotExpr(copy(GetPath,GetDotPos+1))); if ParamContext.Setter=nil then - SetExpr:=CreateDotExpression(El,CreateBuiltInIdentifierExpr('this.'+GetPathName), - CreateBuiltInIdentifierExpr(copy(GetPath,GetDotPos+1))); + SetExpr:=CreateDotExpression(El,CreatePrimitiveDotExpr('this.'+GetPathName), + CreatePrimitiveDotExpr(copy(GetPath,GetDotPos+1))); end else begin @@ -11049,7 +11303,7 @@ begin GetExpr:=FullGetter; FullGetter:=nil; if ParamContext.Setter=nil then - SetExpr:=CreateBuiltInIdentifierExpr(GetPath); + SetExpr:=CreatePrimitiveDotExpr(GetPath); end; if ParamContext.Setter<>nil then @@ -11065,15 +11319,15 @@ begin if LeftStr(GetPath,GetDotPos)=LeftStr(SetPath,SetDotPos) then begin // use GetPathExpr for setter - SetExpr:=CreateDotExpression(El,CreateBuiltInIdentifierExpr('this.'+GetPathName), - CreateBuiltInIdentifierExpr(copy(SetPath,GetDotPos+1))); + SetExpr:=CreateDotExpression(El,CreatePrimitiveDotExpr('this.'+GetPathName), + CreatePrimitiveDotExpr(copy(SetPath,GetDotPos+1))); end else begin // setter needs its own SetPathExpr - SetPathExpr:=CreateBuiltInIdentifierExpr(LeftStr(SetPath,SetDotPos-1)); - SetExpr:=CreateDotExpression(El,CreateBuiltInIdentifierExpr('this.'+SetPathName), - CreateBuiltInIdentifierExpr(copy(SetPath,GetDotPos+1))); + SetPathExpr:=CreatePrimitiveDotExpr(LeftStr(SetPath,SetDotPos-1)); + SetExpr:=CreateDotExpression(El,CreatePrimitiveDotExpr('this.'+SetPathName), + CreatePrimitiveDotExpr(copy(SetPath,GetDotPos+1))); end; end; end; @@ -11092,12 +11346,12 @@ begin // SetExpr: this.p.i DotExpr:=TJSDotMemberExpression(FullGetter); GetPathExpr:=DotExpr.MExpr; - DotExpr.MExpr:=CreateBuiltInIdentifierExpr('this.'+GetPathName); + DotExpr.MExpr:=CreatePrimitiveDotExpr('this.'+GetPathName); GetExpr:=DotExpr; FullGetter:=nil; SetExpr:=CreateDotExpression(El, - CreateBuiltInIdentifierExpr('this.'+GetPathName), - CreateBuiltInIdentifierExpr(String(DotExpr.Name))); + CreatePrimitiveDotExpr('this.'+GetPathName), + CreatePrimitiveDotExpr(String(DotExpr.Name))); end else if FullGetter.ClassType=TJSBracketMemberExpression then begin @@ -11113,12 +11367,12 @@ begin ParamExpr:=BracketExpr.Name; // create "a:value" - BracketExpr.Name:=CreateBuiltInIdentifierExpr('this.'+ParamName); + BracketExpr.Name:=CreatePrimitiveDotExpr('this.'+ParamName); AddVar(ParamName,ParamExpr); // create GetPathExpr "this.arr" GetPathExpr:=BracketExpr.MExpr; - BracketExpr.MExpr:=CreateBuiltInIdentifierExpr('this.'+GetPathName); + BracketExpr.MExpr:=CreatePrimitiveDotExpr('this.'+GetPathName); // GetExpr "this.p[this.a]" GetExpr:=BracketExpr; @@ -11127,8 +11381,8 @@ begin // SetExpr "this.p[this.a]" BracketExpr:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El)); SetExpr:=BracketExpr; - BracketExpr.MExpr:=CreateBuiltInIdentifierExpr('this.'+GetPathName); - BracketExpr.Name:=CreateBuiltInIdentifierExpr('this.'+ParamName); + BracketExpr.MExpr:=CreatePrimitiveDotExpr('this.'+GetPathName); + BracketExpr.Name:=CreatePrimitiveDotExpr('this.'+ParamName); end else @@ -11146,7 +11400,7 @@ begin // create SetExpr = v; AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); AssignSt.LHS:=SetExpr; - AssignSt.Expr:=CreateBuiltInIdentifierExpr(TempRefObjSetterArgName); + AssignSt.Expr:=CreatePrimitiveDotExpr(TempRefObjSetterArgName); SetExpr:=AssignSt; end else if (SetExpr.ClassType=TJSCallExpression) then @@ -11217,7 +11471,7 @@ begin // create "T.isPrototypeOf(exceptObject)" Call:=CreateCallExpression(El); Call.Expr:=DotExpr; - Call.AddArg(CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnExceptObject])); + Call.AddArg(CreatePrimitiveDotExpr(FBuiltInNames[pbivnExceptObject])); IfSt.Cond:=Call; if El.VarEl<>nil then @@ -11227,7 +11481,7 @@ begin ListLast:=ListFirst; IfSt.BTrue:=ListFirst; V:=CreateVarStatement(TransformVariableName(El,El.VariableName,AContext), - CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnExceptObject]),El); + CreatePrimitiveDotExpr(FBuiltInNames[pbivnExceptObject]),El); ListFirst.A:=V; // add statements AddToStatementList(ListFirst,ListLast,ConvertElement(El.Body,AContext),El); @@ -11449,7 +11703,7 @@ const VarAssignSt.LHS:=CreateSubDeclNameExpr(PasVar,PasVar.Name,FuncContext); VarDotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,PasVar)); VarAssignSt.Expr:=VarDotExpr; - VarDotExpr.MExpr:=CreateBuiltInIdentifierExpr(SrcParamName); + VarDotExpr.MExpr:=CreatePrimitiveDotExpr(SrcParamName); VarDotExpr.Name:=TJSString(TransformVariableName(PasVar,FuncContext)); if (AContext.Resolver<>nil) then begin @@ -11666,7 +11920,7 @@ begin IfSt:=TJSIfStatement(CreateElement(TJSIfStatement,El)); AddToStatementList(BodyFirst,BodyLast,IfSt,El); FD.Body.A:=BodyFirst; - IfSt.Cond:=CreateBuiltInIdentifierExpr(SrcParamName); + IfSt.Cond:=CreatePrimitiveDotExpr(SrcParamName); // add clone statements AddCloneStatements(IfSt,FuncContext); // add init default statements @@ -11698,7 +11952,7 @@ begin // ); Call:=CreateCallExpression(El); Call.Expr:=CreateDotExpression(El,List.B, - CreateBuiltInIdentifierExpr(FBuiltInNames[pbifnRTTIAddFields])); + CreatePrimitiveDotExpr(FBuiltInNames[pbifnRTTIAddFields])); List.B:=Call; AddRTTIFields(Call.Args); end; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 7d604c8c10..566edca2d2 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -366,7 +366,11 @@ type Procedure TestClass_NestedSelf; Procedure TestClass_NestedClassSelf; Procedure TestClass_NestedCallInherited; - Procedure TestClass_TObjectFree; // ToDO + Procedure TestClass_TObjectFree; + Procedure TestClass_TObjectFreeNewInstance; + Procedure TestClass_TObjectFreeLowerCase; + Procedure TestClass_TObjectFreeFunctionFail; + Procedure TestClass_TObjectFreePropertyFail; // class of Procedure TestClassOf_Create; @@ -5787,13 +5791,13 @@ begin Add('function GetRec(vB: integer = 0): TRecord;'); Add('begin'); Add('end;'); - Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);'); + Add('procedure DoIt(vG: integer; const vH: integer);'); Add('begin'); Add('end;'); Add('begin'); - Add(' doit(getrec.i,getrec.i,getrec.i);'); - Add(' doit(getrec().i,getrec().i,getrec().i);'); - Add(' doit(getrec(1).i,getrec(2).i,getrec(3).i);'); + Add(' doit(getrec.i,getrec.i);'); + Add(' doit(getrec().i,getrec().i);'); + Add(' doit(getrec(1).i,getrec(2).i);'); ConvertProgram; CheckSource('TestRecordElementFromFuncResult_AsParams', LinesToStr([ // statements @@ -5811,37 +5815,13 @@ begin ' var Result = new $mod.TRecord();', ' return Result;', '};', - 'this.DoIt = function (vG,vH,vI) {', + 'this.DoIt = function (vG,vH) {', '};' ]), LinesToStr([ - '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i,{', - ' p: $mod.GetRec(0),', - ' get: function () {', - ' return this.p.i;', - ' },', - ' set: function (v) {', - ' this.p.i = v;', - ' }', - '});', - '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i,{', - ' p: $mod.GetRec(0),', - ' get: function () {', - ' return this.p.i;', - ' },', - ' set: function (v) {', - ' this.p.i = v;', - ' }', - '});', - '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i,{', - ' p: $mod.GetRec(3),', - ' get: function () {', - ' return this.p.i;', - ' },', - ' set: function (v) {', - ' this.p.i = v;', - ' }', - '});', + '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);', + '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);', + '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);', ''])); end; @@ -8196,8 +8176,6 @@ end; procedure TTestModule.TestClass_TObjectFree; begin - exit; - StartProgram(false); Add([ 'type', @@ -8214,24 +8192,30 @@ begin ' o.free;', ' o.free();', ' l.free;', + ' l.free();', ' o.obj.free;', ' o.obj.free();', + ' with o do obj.free;', + ' with o do obj.free();', ' result.Free;', ' result.Free();', 'end;', 'var o: tobject;', + ' a: array of tobject;', 'begin', ' o.free;', ' o.obj.free;', + ' a[1+2].free;', '']); ConvertProgram; - CheckSource('TestClass_NestedCallInherited', + CheckSource('TestClass_TObjectFree', LinesToStr([ // statements 'rtl.createClass($mod, "TObject", null, function () {', ' this.$init = function () {', ' this.Obj = null;', ' };', ' this.$final = function () {', + ' this.Obj = undefined;', ' };', ' this.Free = function () {', ' };', @@ -8239,14 +8223,142 @@ begin 'this.DoIt = function (o) {', ' var Result = null;', ' var l = null;', + ' o = rtl.freeLoc(o);', + ' o = rtl.freeLoc(o);', + ' l = rtl.freeLoc(l);', + ' l = rtl.freeLoc(l);', + ' rtl.free(o, "Obj");', + ' rtl.free(o, "Obj");', + ' var $with1 = o;', + ' rtl.free($with1, "Obj");', + ' var $with2 = o;', + ' rtl.free($with2, "Obj");', + ' Result = rtl.freeLoc(Result);', + ' Result = rtl.freeLoc(Result);', ' return Result;', '};', 'this.o = null;', + 'this.a = [];', '']), LinesToStr([ // $mod.$main + 'rtl.free($mod, "o");', + 'rtl.free($mod.o, "Obj");', + 'rtl.free($mod.a, 1 + 2);', ''])); end; +procedure TTestModule.TestClass_TObjectFreeNewInstance; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' constructor Create;', + ' procedure Free;', + ' end;', + 'constructor TObject.Create; begin end;', + 'procedure tobject.free; begin end;', + 'begin', + ' with tobject.create do free;', + '']); + ConvertProgram; + CheckSource('TestClass_TObjectFreeNewInstance', + LinesToStr([ // statements + 'rtl.createClass($mod, "TObject", null, function () {', + ' this.$init = function () {', + ' };', + ' this.$final = function () {', + ' };', + ' this.Create = function () {', + ' };', + ' this.Free = function () {', + ' };', + '});', + '']), + LinesToStr([ // $mod.$main + 'var $with1 = $mod.TObject.$create("Create");', + '$with1=rtl.freeLoc($with1);', + ''])); +end; + +procedure TTestModule.TestClass_TObjectFreeLowerCase; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' destructor Destroy;', + ' procedure Free;', + ' end;', + 'destructor TObject.Destroy; begin end;', + 'procedure tobject.free; begin end;', + 'var o: tobject;', + 'begin', + ' o.free;', + '']); + Converter.UseLowerCase:=true; + ConvertProgram; + CheckSource('TestClass_TObjectFreeLowerCase', + LinesToStr([ // statements + 'rtl.createClass($mod, "tobject", null, function () {', + ' this.$init = function () {', + ' };', + ' this.$final = function () {', + ' };', + ' rtl.tObjectDestroy = "destroy";', + ' this.destroy = function () {', + ' };', + ' this.free = function () {', + ' };', + '});', + 'this.o = null;', + '']), + LinesToStr([ // $mod.$main + 'rtl.free($mod, "o");', + ''])); +end; + +procedure TTestModule.TestClass_TObjectFreeFunctionFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' procedure Free;', + ' function GetObj: tobject; virtual; abstract;', + ' end;', + 'procedure tobject.free;', + 'begin', + 'end;', + 'var o: tobject;', + 'begin', + ' o.getobj.free;', + '']); + SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar); + ConvertProgram; +end; + +procedure TTestModule.TestClass_TObjectFreePropertyFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' procedure Free;', + ' FObj: TObject;', + ' property Obj: tobject read FObj write FObj;', + ' end;', + 'procedure tobject.free;', + 'begin', + 'end;', + 'var o: tobject;', + 'begin', + ' o.obj.free;', + '']); + SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar); + ConvertProgram; +end; + procedure TTestModule.TestClassOf_Create; begin StartProgram(false);