fcl-passrc: resolver: new(out ^record), dispose(^record)

git-svn-id: trunk@38839 -

packages/fcl-passrc/src/pasresolver.pp

@@ -447,7 +447,9 @@ type
     bfInsertArray,
     bfDeleteArray,
     bfTypeInfo,
-    bfAssert
+    bfAssert,
+    bfNew,
+    bfDispose
     );
   TResolverBuiltInProcs = set of TResolverBuiltInProc;
 const
@@ -476,7 +478,9 @@ const
     'Insert',
     'Delete',
     'TypeInfo',
-    'Assert'
+    'Assert',
+    'New',
+    'Dispose'
     );
   bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
 
@@ -1463,6 +1467,14 @@ type
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     procedure BI_Assert_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
       Params: TParamsExpr); virtual;
+    function BI_New_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
+    procedure BI_New_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
+      Params: TParamsExpr); virtual;
+    function BI_Dispose_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
+    procedure BI_Dispose_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
+      Params: TParamsExpr); virtual;
   public
     constructor Create;
     destructor Destroy; override;
@@ -11327,7 +11339,7 @@ begin
   Param:=Params.Params[0];
   ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.OnGetCallCompatibility_IncDec ParamResolved=',GetResolverResultDbg(ParamResolved));
+  writeln('TPasResolver.BI_IncDec_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
   {$ENDIF}
   Result:=cIncompatible;
   // Expr must be a variable
@@ -12355,6 +12367,98 @@ begin
   FinishAssertCall(Proc,Params);
 end;
 
+function TPasResolver.BI_New_OnGetCallCompatibility(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+var
+  Params: TParamsExpr;
+  Param: TPasExpr;
+  TypeEl, SubTypeEl: TPasType;
+  ParamResolved: TPasResolverResult;
+begin
+  if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
+    exit(cIncompatible);
+  Params:=TParamsExpr(Expr);
+
+  // first param: var PRecord
+  Param:=Params.Params[0];
+  ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.BI_New_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
+  {$ENDIF}
+  Result:=cIncompatible;
+  // Expr must be a variable
+  if not ResolvedElCanBeVarParam(ParamResolved) then
+    begin
+    if RaiseOnError then
+      RaiseMsg(20180425005303,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
+    exit;
+    end;
+  if ParamResolved.BaseType=btContext then
+    begin
+    TypeEl:=ResolveAliasType(ParamResolved.TypeEl);
+    if TypeEl.ClassType=TPasPointerType then
+      begin
+      SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
+      if SubTypeEl.ClassType=TPasRecordType then
+        Result:=cExact;
+      end;
+    end;
+  if Result=cIncompatible then
+    exit(CheckRaiseTypeArgNo(20180425005421,1,Param,ParamResolved,'pointer of record',RaiseOnError));
+
+  Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
+end;
+
+procedure TPasResolver.BI_New_OnFinishParamsExpr(
+  Proc: TResElDataBuiltInProc; Params: TParamsExpr);
+begin
+  if Proc=nil then ;
+  FinishCallArgAccess(Params.Params[0],rraOutParam);
+end;
+
+function TPasResolver.BI_Dispose_OnGetCallCompatibility(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+var
+  Params: TParamsExpr;
+  Param: TPasExpr;
+  TypeEl, SubTypeEl: TPasType;
+  ParamResolved: TPasResolverResult;
+begin
+  if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
+    exit(cIncompatible);
+  Params:=TParamsExpr(Expr);
+
+  // first param: var PRecord
+  Param:=Params.Params[0];
+  ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.BI_Dispose_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
+  {$ENDIF}
+  Result:=cIncompatible;
+  if (rrfReadable in ParamResolved.Flags) then
+    if ParamResolved.BaseType=btContext then
+      begin
+      TypeEl:=ResolveAliasType(ParamResolved.TypeEl);
+      if TypeEl.ClassType=TPasPointerType then
+        begin
+        SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
+        if SubTypeEl.ClassType=TPasRecordType then
+          Result:=cExact;
+        end;
+      end;
+  if Result=cIncompatible then
+    exit(CheckRaiseTypeArgNo(20180425010620,1,Param,ParamResolved,'pointer of record',RaiseOnError));
+
+  Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
+end;
+
+procedure TPasResolver.BI_Dispose_OnFinishParamsExpr(
+  Proc: TResElDataBuiltInProc; Params: TParamsExpr);
+begin
+  if Proc=nil then ;
+  FinishCallArgAccess(Params.Params[0],rraRead);
+end;
+
 constructor TPasResolver.Create;
 begin
   inherited Create;
@@ -13420,6 +13524,14 @@ begin
     AddBuiltInProc('Assert','procedure Assert(bool[,string])',
         @BI_Assert_OnGetCallCompatibility,nil,nil,
         @BI_Assert_OnFinishParamsExpr,bfAssert,[bipfCanBeStatement]);
+  if bfNew in TheBaseProcs then
+    AddBuiltInProc('New','procedure New(out ^record)',
+        @BI_New_OnGetCallCompatibility,nil,nil,
+        @BI_New_OnFinishParamsExpr,bfNew,[bipfCanBeStatement]);
+  if bfDispose in TheBaseProcs then
+    AddBuiltInProc('Dispose','procedure Dispose(var ^record)',
+        @BI_Dispose_OnGetCallCompatibility,nil,nil,
+        @BI_Dispose_OnFinishParamsExpr,bfDispose,[bipfCanBeStatement]);
 end;
 
 function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType

packages/fcl-passrc/tests/tcresolver.pas

@@ -429,6 +429,7 @@ type
     Procedure TestRecord_WriteNestedConstParamFail;
     Procedure TestRecord_WriteNestedConstParamWithFail;
     Procedure TestRecord_TypeCast;
+    Procedure TestRecord_NewDispose;
 
     // class
     Procedure TestClass;
@@ -6685,6 +6686,27 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestRecord_NewDispose;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TBird = record',
+  '    Length: longint;',
+  '  end;',
+  '  PBird = ^TBird;',
+  'var',
+  '  p: PBird;',
+  '  q: ^TBird;',
+  'begin',
+  '  New(p);',
+  '  Dispose(p);',
+  '  New(q);',
+  '  Dispose(q);',
+  '  ']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClass;
 begin
   StartProgram(false);