fcl-passrc: resolver: assert()

git-svn-id: trunk@37984 -

packages/fcl-passrc/src/pasresolver.pp

@@ -414,7 +414,8 @@ type
     bfCopyArray,
     bfInsertArray,
     bfDeleteArray,
-    bfTypeInfo
+    bfTypeInfo,
+    bfAssert
     );
   TResolverBuiltInProcs = set of TResolverBuiltInProc;
 const
@@ -442,7 +443,8 @@ const
     'Copy',
     'Insert',
     'Delete',
-    'TypeInfo'
+    'TypeInfo',
+    'Assert'
     );
   bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
 
@@ -1275,6 +1277,8 @@ type
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     procedure BI_TypeInfo_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc;
       {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
+    function BI_Assert_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
   public
     constructor Create;
     destructor Destroy; override;
@@ -10178,6 +10182,40 @@ begin
   SetResolverTypeExpr(ResolvedEl,btPointer,FBaseTypes[btPointer],[rrfReadable]);
 end;
 
+function TPasResolver.BI_Assert_OnGetCallCompatibility(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+// check params of built-in procedure 'Assert'
+//  Assert(bool)
+//  Assert(bool,string)
+var
+  Params: TParamsExpr;
+  Param: TPasExpr;
+  ParamResolved: TPasResolverResult;
+begin
+  if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
+    exit(cIncompatible);
+  Params:=TParamsExpr(Expr);
+
+  // first param: boolean
+  Param:=Params.Params[0];
+  ComputeElement(Param,ParamResolved,[]);
+  if not (rrfReadable in ParamResolved.Flags)
+     or not (ParamResolved.BaseType in btAllBooleans) then
+    exit(CheckRaiseTypeArgNo(20180117123819,1,Param,ParamResolved,'boolean',RaiseOnError));
+
+  // optional second parameter: string
+  if length(Params.Params)>1 then
+    begin
+    Param:=Params.Params[1];
+    ComputeElement(Param,ParamResolved,[]);
+    if not (rrfReadable in ParamResolved.Flags)
+       or not (ParamResolved.BaseType in btAllStringAndChars) then
+      exit(CheckRaiseTypeArgNo(20180117123932,2,Param,ParamResolved,'string',RaiseOnError));
+    end;
+
+  Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError);
+end;
+
 constructor TPasResolver.Create;
 begin
   inherited Create;
@@ -11139,6 +11177,9 @@ begin
     AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
         @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
         nil,nil,bfTypeInfo);
+  if bfAssert in TheBaseProcs then
+    AddBuiltInProc('Assert','procedure Assert(bool[,string])',
+        @BI_Assert_OnGetCallCompatibility,nil,nil,nil,bfAssert,[bipfCanBeStatement]);
 end;
 
 function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType

packages/fcl-passrc/tests/tcresolver.pas

@@ -202,12 +202,15 @@ type
     Procedure TestConstIntOperators;
     Procedure TestConstBitwiseOps;
     Procedure TestIntegerTypeCast;
-    Procedure TestConstBoolOperators;
-    Procedure TestBoolTypeCast;
     Procedure TestConstFloatOperators;
     Procedure TestFloatTypeCast;
+
+    // boolean
+    Procedure TestBoolTypeCast;
+    Procedure TestConstBoolOperators;
     Procedure TestBoolSet_Const;
     Procedure TestBool_ForIn;
+    Procedure TestBool_Assert;
 
     // integer range
     Procedure TestIntegerRange;
@@ -2386,36 +2389,6 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
-procedure TTestResolver.TestConstBoolOperators;
-begin
-  StartProgram(false);
-  Add([
-  'const',
-  '  a=true and false;',
-  '  b=true or false;',
-  '  c=true xor false;',
-  '  d=not b;',
-  '  e=a=b;',
-  '  f=a<>b;',
-  '  g=low(boolean) or high(boolean);',
-  '  h=succ(false) or pred(true);',
-  '  i=ord(false)+ord(true);',
-  'begin']);
-  ParseProgram;
-  CheckResolverUnexpectedHints;
-end;
-
-procedure TTestResolver.TestBoolTypeCast;
-begin
-  StartProgram(false);
-  Add('var');
-  Add('  a: boolean = boolean(0);');
-  Add('  b: boolean = boolean(1);');
-  Add('begin');
-  ParseProgram;
-  CheckResolverUnexpectedHints;
-end;
-
 procedure TTestResolver.TestConstFloatOperators;
 begin
   StartProgram(false);
@@ -2453,6 +2426,36 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
+procedure TTestResolver.TestBoolTypeCast;
+begin
+  StartProgram(false);
+  Add('var');
+  Add('  a: boolean = boolean(0);');
+  Add('  b: boolean = boolean(1);');
+  Add('begin');
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
+procedure TTestResolver.TestConstBoolOperators;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  a=true and false;',
+  '  b=true or false;',
+  '  c=true xor false;',
+  '  d=not b;',
+  '  e=a=b;',
+  '  f=a<>b;',
+  '  g=low(boolean) or high(boolean);',
+  '  h=succ(false) or pred(true);',
+  '  i=ord(false)+ord(true);',
+  'begin']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
 procedure TTestResolver.TestBoolSet_Const;
 begin
   StartProgram(false);
@@ -2497,6 +2500,22 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestBool_Assert;
+begin
+  StartProgram(false);
+  Add([
+  'var',
+  '  b : boolean;',
+  '  s: string;',
+  'begin',
+  '  Assert(true);',
+  '  Assert(b);',
+  '  Assert(b,''error'');',
+  '  Assert(false,''error''+s);',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestIntegerRange;
 begin
   StartProgram(false);