diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 89595e0cfa..e66dbea659 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -1300,6 +1300,7 @@ type Ref: TResolvedReference); virtual; function GetVisibilityContext: TPasElement; procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override; + function NeedArrayValues(El: TPasElement): boolean; override; // built in types and functions procedure ClearBuiltInIdentifiers; virtual; procedure AddObjFPCBuiltInIdentifiers( @@ -1437,6 +1438,7 @@ type function IsDynArray(TypeEl: TPasType): boolean; function IsOpenArray(TypeEl: TPasType): boolean; function IsDynOrOpenArray(TypeEl: TPasType): boolean; + function IsVarInit(Expr: TPasExpr): boolean; function IsEmptySet(const ResolvedEl: TPasResolverResult): boolean; function IsClassMethod(El: TPasElement): boolean; function IsExternalClassName(aClass: TPasClassType; const ExtName: string): boolean; @@ -8515,6 +8517,26 @@ begin end; end; +function TPasResolver.NeedArrayValues(El: TPasElement): boolean; +// called by the parser when reading DoParseConstValueExpression +var + C: TClass; + V: TPasVariable; + TypeEl: TPasType; +begin + Result:=false; + if El=nil then exit; + C:=El.ClassType; + if (C=TPasConst) or (C=TPasVariable) then + begin + V:=TPasVariable(El); + if V.VarType=nil then exit; + TypeEl:=ResolveAliasType(V.VarType); + Result:=TypeEl.ClassType=TPasArrayType; + end; + //writeln('TPasResolver.NeedArrayValues ',GetObjName(El)); +end; + class procedure TPasResolver.UnmangleSourceLineNumber(LineNumber: integer; out Line, Column: integer); begin @@ -10561,10 +10583,17 @@ function TPasResolver.CheckAssignCompatibilityArrayType(const LHS, Count:=length(TArrayValues(Expr).Values) else if (Expr.ClassType=TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then Count:=length(TParamsExpr(Expr).Params) + else if (Values.BaseType in btAllStringAndChars) and IsVarInit(Expr) then + begin + // const a: dynarray = string + ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]); + if ElTypeResolved.BaseType in btAllChars then + Result:=cExact; + exit; + end else begin - if RaiseOnIncompatible then - RaiseNotYetImplemented(20170420151703,Expr,'assign one value to a dynamic array'); + // single value exit; end; end; @@ -11775,19 +11804,36 @@ begin and (length(TPasArrayType(TypeEl).Ranges)=0); end; +function TPasResolver.IsVarInit(Expr: TPasExpr): boolean; +var + C: TClass; +begin + Result:=false; + if Expr=nil then exit; + if Expr.Parent=nil then exit; + C:=Expr.Parent.ClassType; + if C.InheritsFrom(TPasVariable) then + Result:=(TPasVariable(Expr.Parent).Expr=Expr) + else if C=TPasArgument then + Result:=(TPasArgument(Expr.Parent).ValueExpr=Expr); +end; + function TPasResolver.IsEmptySet(const ResolvedEl: TPasResolverResult): boolean; begin Result:=(ResolvedEl.BaseType=btSet) and (ResolvedEl.SubType=btNone); end; function TPasResolver.IsClassMethod(El: TPasElement): boolean; +var + C: TClass; begin - Result:=(El<>nil) - and ((El.ClassType=TPasClassConstructor) - or (El.ClassType=TPasClassDestructor) - or (El.ClassType=TPasClassProcedure) - or (El.ClassType=TPasClassFunction) - or (El.ClassType=TPasClassOperator)); + if El=nil then exit(false); + C:=El.ClassType;; + Result:=(C=TPasClassConstructor) + or (C=TPasClassDestructor) + or (C=TPasClassProcedure) + or (C=TPasClassFunction) + or (C=TPasClassOperator); end; function TPasResolver.IsExternalClassName(aClass: TPasClassType; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index d319b387cd..ee527f2453 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -182,6 +182,7 @@ type function FindElement(const AName: String): TPasElement; virtual; abstract; procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual; function FindModule(const AName: String): TPasModule; virtual; + function NeedArrayValues(El: TPasElement): boolean; virtual; property Package: TPasPackage read FPackage; property InterfaceOnly : Boolean Read FInterfaceOnly Write FInterFaceOnly; property ScannerLogEvents : TPScannerLogEvents Read FScannerLogEvents Write FScannerLogEvents; @@ -731,6 +732,12 @@ begin Result := nil; end; +function TPasTreeContainer.NeedArrayValues(El: TPasElement): boolean; +begin + Result:=false; + if El=nil then ; +end; + { --------------------------------------------------------------------- EParserError ---------------------------------------------------------------------} @@ -2085,11 +2092,6 @@ begin end; function TPasParser.DoParseConstValueExpression(AParent: TPasElement): TPasExpr; -var - x : TPasExpr; - n : AnsiString; - r : TRecordValues; - a : TArrayValues; function lastfield:boolean; @@ -2105,76 +2107,95 @@ var end; end; + procedure ReadArrayValues(x : TPasExpr); + var + a: TArrayValues; + begin + Result:=nil; + a:=nil; + try + a:=CreateArrayValues(AParent); + if x<>nil then + begin + a.AddValues(x); + x:=nil; + end; + repeat + NextToken; + a.AddValues(DoParseConstValueExpression(AParent)); + until CurToken<>tkComma; + Result:=a; + finally + if Result=nil then + begin + a.Free; + x.Free; + end; + end; + end; + +var + x : TPasExpr; + n : AnsiString; + r : TRecordValues; begin if CurToken <> tkBraceOpen then Result:=DoParseExpression(AParent) else begin Result:=nil; - NextToken; - x:=DoParseConstValueExpression(AParent); - case CurToken of - tkComma: // array of values (a,b,c); - try - a:=CreateArrayValues(AParent); - a.AddValues(x); - x:=nil; - repeat - NextToken; - x:=DoParseConstValueExpression(AParent); - a.AddValues(x); - x:=nil; - until CurToken<>tkComma; - Result:=a; - finally - if Result=nil then - begin - a.Free; - x.Free; - end; - end; - - tkColon: // record field (a:xxx;b:yyy;c:zzz); - begin - r:=nil; - try - n:=GetExprIdent(x); - ReleaseAndNil(TPasElement(x)); - r:=CreateRecordValues(AParent); - NextToken; - x:=DoParseConstValueExpression(AParent); - r.AddField(n, x); - x:=nil; - if not lastfield then - repeat - n:=ExpectIdentifier; - ExpectToken(tkColon); - NextToken; - x:=DoParseConstValueExpression(AParent); - r.AddField(n, x); - x:=nil; - until lastfield; // CurToken<>tkSemicolon; - Result:=r; - finally - if Result=nil then - begin - r.Free; - x.Free; - end; - end; - end; + if Engine.NeedArrayValues(AParent) then + ReadArrayValues(nil) else - // Binary expression! ((128 div sizeof(longint)) - 3); - Result:=DoParseExpression(AParent,x); - if CurToken<>tkBraceClose then - begin - ReleaseAndNil(TPasElement(Result)); - ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket); - end; + begin NextToken; - if CurToken <> tkSemicolon then // the continue of expression - Result:=DoParseExpression(AParent,Result); - Exit; - end; + x:=DoParseConstValueExpression(AParent); + case CurToken of + tkComma: // array of values (a,b,c); + ReadArrayValues(x); + + tkColon: // record field (a:xxx;b:yyy;c:zzz); + begin + r:=nil; + try + n:=GetExprIdent(x); + ReleaseAndNil(TPasElement(x)); + r:=CreateRecordValues(AParent); + NextToken; + x:=DoParseConstValueExpression(AParent); + r.AddField(n, x); + x:=nil; + if not lastfield then + repeat + n:=ExpectIdentifier; + ExpectToken(tkColon); + NextToken; + x:=DoParseConstValueExpression(AParent); + r.AddField(n, x); + x:=nil; + until lastfield; // CurToken<>tkSemicolon; + Result:=r; + finally + if Result=nil then + begin + r.Free; + x.Free; + end; + end; + end; + else + // Binary expression! ((128 div sizeof(longint)) - 3); + Result:=DoParseExpression(AParent,x); + if CurToken<>tkBraceClose then + begin + ReleaseAndNil(TPasElement(Result)); + ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket); + end; + NextToken; + if CurToken <> tkSemicolon then // the continue of expression + Result:=DoParseExpression(AParent,Result); + Exit; + end; + end; if CurToken<>tkBraceClose then begin ReleaseAndNil(TPasElement(Result)); diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index b4ed183500..f9a1fe9996 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -498,6 +498,7 @@ type Procedure TestArrayEnumTypeConstWrongTypeFail; Procedure TestArrayEnumTypeConstNonConstFail; Procedure TestArrayEnumTypeSetLengthFail; + Procedure TestArray_DynArrayConst; Procedure TestArray_AssignNilToStaticArrayFail1; Procedure TestArray_SetLengthProperty; Procedure TestArray_PassArrayElementToVarParam; @@ -7895,6 +7896,26 @@ begin nIncompatibleTypeArgNo); end; +procedure TTestResolver.TestArray_DynArrayConst; +begin + StartProgram(false); + Add([ + 'type', + ' integer = longint;', + ' TArrInt = array of integer;', + ' TArrStr = array of string;', + 'const', + ' Ints: TArrInt = (1,2,3);', + ' Names: array of string = (''a'',''foo'');', + ' Aliases: TarrStr = (''foo'',''b'');', + ' OneInt: TArrInt = (7);', + ' OneStr: array of integer = (7);', + ' Chars: array of char = ''aoc'';', + 'begin', + '']); + ParseProgram; +end; + procedure TTestResolver.TestArray_AssignNilToStaticArrayFail1; begin StartProgram(false);