* New patch from Mattias Gaertner

* pscanner: 
  New TPasSourcePos record and function TPascalScanner.CurSourcePos: TPasSourcePos.
  TStreamResolver.Streams public, so the tests can find all sources. 

* pastree:
  TPasImplForLoop.VariableName is now TPasExpr.
  Replaced Element.Free calls with Element.Release.

* pparser: 
  Improved the source positions of many types, by passing a TPasSourcePos with TypeName.
  Replaced Element.Free calls with Element.Release.
  Changed try..except to try..finally for nicer stacktraces.
  FinishScope ExceptOnExpr:  called after expression was parsed, before statement 
  FinishScope ExceptOn: called after statement.
  For-Loop now supports a dotted identifier as variablename.

* pasresolver:
  while do
  repeat until
  if then else
  binary operators
  case of
  try..finally..except, on, else, raise
  for loop

* Tests:
  Changed for-loop tests for new VariableName.
  Testing the resolver with Asserts creates hard to understand tests.
  Instead I added an utility function CheckReferenceDirectives to test
  resolved references via markers in source snippets. This also tests the
  element structure and source positions.

git-svn-id: trunk@34429 -

packages/fcl-passrc/src/pasresolver.pp

@@ -31,32 +31,46 @@
   - alias types, 'type a=b'
   - type alias type 'type a=type b'
   - choose the compatible overloaded procedure
+  - while do
+  - repeat until
+  - if then else
+  - binary operators
+  - case of
+  - try..finally..except, on, else, raise
+  - for loop
 
  ToDo:
   - spot duplicates
   - check if types only refer types
+  - nested forward procs, nested must be resolved before proc body
+  - program/library/implementation forward procs
   - check if constant is longint or int64
   - built-in functions
-  - enums, propagate to parent scopes
-  - records
-  - arrays
-  - pointer
+  - enums - TPasEnumType, TPasEnumValue
+    - propagate to parent scopes
+  - ranges TPasRangeType
+  - records - TPasRecordType,
+    - variant - TPasVariant
+    - const  TRecordValues
+  - arrays  TPasArrayType
+    - const TArrayValues
+  - pointer TPasPointerType
   - untyped parameters
-  - ranges
-  - sets
+  - sets - TPasSetType
   - forwards of ^pointer and class of - must be queued and resolved at end of type section
-  - with
-  - classes
+  - with - TPasImplWithDo
+  - classes - TPasClassType
   - interfaces
-  - properties
-    - read
-    - write
-    - index properties
+  - properties - TPasProperty
+    - read, write, index properties, implements, stored
   - default property
+  - TPasResString
+  - TPasFileType
   - generics, nested param lists
   - visibility (private, protected, strict private, strict protected)
   - check const expression types, e.g. bark on "const c:string=3;"
   - dotted unitnames
+  - labels
   - helpers
   - generics
   - many more: search for "ToDo:"
@@ -372,7 +386,11 @@ type
   { TPasProcedureScope }
 
   TPasProcedureScope = Class(TPasIdentifierScope)
-  public
+  end;
+
+  { TPasExceptOnScope }
+
+  TPasExceptOnScope = Class(TPasIdentifierScope)
   end;
 
   { TPasSubScope - base class for sub scopes }
@@ -474,27 +492,31 @@ type
   protected
     procedure SetCurrentParser(AValue: TPasParser); override;
     procedure CheckTopScope(ExpectedClass: TPasScopeClass);
+    procedure AddModule(El: TPasModule);
+    procedure AddSection(El: TPasSection);
+    procedure AddType(El: TPasType);
+    procedure AddVariable(El: TPasVariable);
+    procedure AddProcedure(El: TPasProcedure);
+    procedure AddArgument(El: TPasArgument);
+    procedure AddFunctionResult(El: TPasResultElement);
+    procedure AddExceptOn(El: TPasImplExceptOn);
+    procedure StartProcedureBody(El: TProcedureBody);
     procedure FinishModule;
     procedure FinishUsesList;
     procedure FinishTypeSection;
     procedure FinishProcedure;
     procedure FinishProcedureHeader;
+    procedure FinishExceptOnExpr;
+    procedure FinishExceptOnStatement;
     procedure ResolveImplBlock(Block: TPasImplBlock);
     procedure ResolveImplElement(El: TPasImplElement);
     procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf);
+    procedure ResolveImplLabelMark(Mark: TPasImplLabelMark);
     procedure ResolveImplForLoop(Loop: TPasImplForLoop);
     procedure ResolveExpr(El: TPasExpr);
     procedure ResolveBinaryExpr(El: TBinaryExpr);
     procedure ResolveSubIdent(El: TBinaryExpr);
     procedure ResolveParamsExpr(Params: TParamsExpr);
-    procedure AddModule(El: TPasModule);
-    procedure AddSection(El: TPasSection);
-    procedure AddType(El: TPasType);
-    procedure AddVariable(El: TPasVariable);
-    procedure AddProcedure(El: TPasProcedure);
-    procedure AddArgument(El: TPasArgument);
-    procedure AddFunctionResult(El: TPasResultElement);
-    procedure StartProcedureBody(El: TProcedureBody);
     procedure WriteScopes;
   public
     constructor Create;
@@ -503,6 +525,10 @@ type
       AParent: TPasElement; AVisibility: TPasMemberVisibility;
       const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
       overload; override;
+    function CreateElement(AClass: TPTreeElement; const AName: String;
+      AParent: TPasElement; AVisibility: TPasMemberVisibility;
+      const ASrcPos: TPasSourcePos): TPasElement;
+      overload; override;
     function FindElement(const AName: String): TPasElement; override;
     function FindFirstElement(const AName: String; ErrorPosEl: TPasElement): TPasElement;
     procedure IterateElements(const aName: string;
@@ -1220,6 +1246,34 @@ begin
   // ToDo: check class
 end;
 
+procedure TPasResolver.FinishExceptOnExpr;
+var
+  El: TPasImplExceptOn;
+  Expr: TPrimitiveExpr;
+begin
+  CheckTopScope(TPasExceptOnScope);
+  El:=TPasImplExceptOn(FTopScope.Element);
+  if El.VarExpr<>nil then
+    begin
+    if El.VarExpr.ClassType<>TPrimitiveExpr then
+      RaiseNotYetImplemented(El.VarExpr);
+    Expr:=TPrimitiveExpr(El.VarExpr);
+    if Expr.Kind<>pekIdent then
+      RaiseNotYetImplemented(Expr);
+    TPasExceptOnScope(FTopScope).AddIdentifier(Expr.Value,Expr,pikSimple);
+    end;
+  if El.TypeExpr<>nil then
+    ResolveExpr(El.TypeExpr);
+end;
+
+procedure TPasResolver.FinishExceptOnStatement;
+begin
+  //writeln('TPasResolver.FinishExceptOnStatement START');
+  CheckTopScope(TPasExceptOnScope);
+  ResolveImplElement(TPasImplExceptOn(FTopScope.Element).Body);
+  PopScope;
+end;
+
 procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock);
 var
   i: Integer;
@@ -1260,6 +1314,8 @@ begin
     end
   else if El.ClassType=TPasImplCaseOf then
     ResolveImplCaseOf(TPasImplCaseOf(El))
+  else if El.ClassType=TPasImplLabelMark then
+    ResolveImplLabelMark(TPasImplLabelMark(El))
   else if El.ClassType=TPasImplForLoop then
     ResolveImplForLoop(TPasImplForLoop(El))
   else if El.ClassType=TPasImplTry then
@@ -1269,11 +1325,7 @@ begin
     ResolveImplBlock(TPasImplTry(El).ElseBranch);
     end
   else if El.ClassType=TPasImplExceptOn then
-    begin
-    ResolveExpr(TPasImplExceptOn(El).VarExpr);
-    ResolveExpr(TPasImplExceptOn(El).TypeExpr);
-    ResolveImplElement(TPasImplExceptOn(El).Body);
-    end
+    // handled in FinishExceptOnStatement
   else if El.ClassType=TPasImplRaise then
     begin
     ResolveExpr(TPasImplRaise(El).ExceptObject);
@@ -1291,26 +1343,43 @@ end;
 procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf);
 var
   i, j: Integer;
+  El: TPasElement;
   Stat: TPasImplCaseStatement;
 begin
   ResolveExpr(CaseOf.CaseExpr);
   for i:=0 to CaseOf.Elements.Count-1 do
     begin
-    Stat:=TPasImplCaseStatement(CaseOf.Elements[i]);
-    for j:=0 to Stat.Expressions.Count-1 do
-      ResolveExpr(TPasExpr(Stat.Expressions[j]));
-    ResolveImplElement(Stat.Body);
+    El:=TPasElement(CaseOf.Elements[i]);
+    if El.ClassType=TPasImplCaseStatement then
+      begin
+      Stat:=TPasImplCaseStatement(El);
+      for j:=0 to Stat.Expressions.Count-1 do
+        begin
+        //writeln('TPasResolver.ResolveImplCaseOf Stat.Expr[',j,']=',GetObjName(El));
+        ResolveExpr(TPasExpr(Stat.Expressions[j]));
+        end;
+      ResolveImplElement(Stat.Body);
+      end
+    else if El.ClassType=TPasImplCaseElse then
+      ResolveImplBlock(TPasImplCaseElse(El))
+    else
+      RaiseNotYetImplemented(El);
     end;
-  ResolveImplBlock(CaseOf.ElseBranch);
+  // CaseOf.ElseBranch was already resolved via Elements
 end;
 
-procedure TPasResolver.ResolveImplForLoop(Loop: TPasImplForLoop);
+procedure TPasResolver.ResolveImplLabelMark(Mark: TPasImplLabelMark);
 var
   DeclEl: TPasElement;
 begin
-  DeclEl:=FindFirstElement(Loop.VariableName,Loop);
-  //writeln('TPasResolver.ResolveImplForLoop Ref=',GetObjName(Loop)+' Decl='+GetObjName(DeclEl));
-  CreateReference(DeclEl,Loop);
+  DeclEl:=FindFirstElement(Mark.LabelId,Mark);
+  // ToDo: check if DeclEl is a label and check duplicate
+  CreateReference(DeclEl,Mark);
+end;
+
+procedure TPasResolver.ResolveImplForLoop(Loop: TPasImplForLoop);
+begin
+  ResolveExpr(Loop.VariableName);
   ResolveExpr(Loop.StartExpr);
   ResolveExpr(Loop.EndExpr);
   ResolveImplElement(Loop.Body);
@@ -1324,7 +1393,8 @@ begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.ResolveExpr ',GetObjName(El));
   {$ENDIF}
-  if El.ClassType=TPrimitiveExpr then
+  if El=nil then
+  else if El.ClassType=TPrimitiveExpr then
     begin
     Primitive:=TPrimitiveExpr(El);
     case Primitive.Kind of
@@ -1589,6 +1659,11 @@ begin
   TPasProcedureScope(TopScope).AddIdentifier(ResolverResultVar,El,pikSimple);
 end;
 
+procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn);
+begin
+  PushScope(El,TPasExceptOnScope);
+end;
+
 procedure TPasResolver.StartProcedureBody(El: TProcedureBody);
 begin
   if El=nil then ;
@@ -1621,34 +1696,48 @@ function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String;
   AParent: TPasElement; AVisibility: TPasMemberVisibility;
   const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
 var
-  SrcFile: String;
   aScanner: TPascalScanner;
-  SrcY, SrcX: Integer;
+  SrcPos: TPasSourcePos;
+begin
+  // get source position for good error messages
+  aScanner:=CurrentParser.Scanner;
+  if (ASourceFilename='') or StoreSrcColumns then
+    begin
+    SrcPos.FileName:=aScanner.CurFilename;
+    SrcPos.Row:=aScanner.CurRow;
+    SrcPos.Column:=aScanner.CurColumn;
+    end
+  else
+    begin
+    SrcPos.FileName:=ASourceFilename;
+    SrcPos.Row:=ASourceLinenumber;
+    SrcPos.Column:=0;
+    end;
+  Result:=CreateElement(AClass,AName,AParent,AVisibility,SrcPos);
+end;
+
+function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String;
+  AParent: TPasElement; AVisibility: TPasMemberVisibility;
+  const ASrcPos: TPasSourcePos): TPasElement;
+var
   El: TPasElement;
+  SrcY: integer;
 begin
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent));
+  writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent),' (',ASrcPos.Row,',',ASrcPos.Column,')');
   {$ENDIF}
   if (AParent=nil) and (FRootElement<>nil)
   and (not AClass.InheritsFrom(TPasUnresolvedTypeRef)) then
     RaiseInternalError('TPasResolver.CreateElement more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement));
 
-  // get source position for good error messages
-  aScanner:=CurrentParser.Scanner;
-  SrcFile:=ASourceFilename;
-  SrcY:=ASourceLinenumber;
-  if (SrcFile='') or StoreSrcColumns then
-    begin
-    SrcFile:=aScanner.CurFilename;
-    SrcY:=aScanner.CurRow;
-    end;
-  if SrcFile='' then
+  if ASrcPos.FileName='' then
     RaiseInternalError('TPasResolver.CreateElement missing filename');
+  SrcY:=ASrcPos.Row;
   if StoreSrcColumns then
     begin
-    SrcX:=aScanner.CurColumn;
-    if (SrcX<ParserMaxEmbeddedColumn) and (SrcY<ParserMaxEmbeddedRow) then
-      SrcY:=-(SrcY*ParserMaxEmbeddedColumn+SrcX);
+    if (ASrcPos.Column<ParserMaxEmbeddedColumn)
+        and (SrcY<ParserMaxEmbeddedRow) then
+      SrcY:=-(SrcY*ParserMaxEmbeddedColumn+ASrcPos.Column);
     end;
 
   // create element
@@ -1656,7 +1745,7 @@ begin
   FLastElement:=El;
   Result:=FLastElement;
   El.Visibility:=AVisibility;
-  El.SourceFilename:=SrcFile;
+  El.SourceFilename:=ASrcPos.FileName;
   El.SourceLinenumber:=SrcY;
   if FRootElement=nil then
     FRootElement:=Result;
@@ -1681,7 +1770,10 @@ begin
   else if AClass.InheritsFrom(TPasModule) then
     AddModule(TPasModule(El))
   else if AClass.InheritsFrom(TPasExpr) then
+  else if AClass.ClassType=TPasImplExceptOn then
+    AddExceptOn(TPasImplExceptOn(El))
   else if AClass.InheritsFrom(TPasImplBlock) then
+  else if AClass.ClassType=TPasImplLabelMark then
   else if AClass.ClassType=TPasOverloadedProc then
   else
     RaiseNotYetImplemented(El);
@@ -1735,6 +1827,10 @@ begin
   stTypeDef: ;
   stProcedure: FinishProcedure;
   stProcedureHeader: FinishProcedureHeader;
+  stExceptOnExpr: FinishExceptOnExpr;
+  stExceptOnStatement: FinishExceptOnStatement;
+  else
+    RaiseMsg(nNotYetImplemented,sNotYetImplemented+' FinishScope',[IntToStr(ord(ScopeType))],nil);
   end;
 end;
 
@@ -1786,9 +1882,28 @@ end;
 
 function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement
   ): TResolvedReference;
+
+  procedure RaiseAlreadySet;
+  var
+    aLine, aCol: integer;
+    FormerDeclEl: TPasElement;
+  begin
+    writeln('RaiseAlreadySet RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
+    UnmangleSourceLineNumber(RefEl.SourceLinenumber,aLine,aCol);
+    writeln('  RefEl at ',RefEl.SourceFilename,'(',aLine,',',aCol,')');
+    writeln('  RefEl.CustomData=',GetObjName(RefEl.CustomData));
+    if RefEl.CustomData is TResolvedReference then
+      begin
+        FormerDeclEl:=TResolvedReference(RefEl.CustomData).Declaration;
+      writeln('  TResolvedReference(RefEl.CustomData).Declaration=',GetObjName(FormerDeclEl),
+       ' IsSame=',FormerDeclEl=DeclEl);
+      end;
+    RaiseInternalError('TPasResolver.CreateReference customdata<>nil');
+  end;
+
 begin
   if RefEl.CustomData<>nil then
-    raise EPasResolve.Create('TPasResolver.CreateReference customdata<>nil');
+    RaiseAlreadySet;
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
   {$ENDIF}
@@ -1912,7 +2027,7 @@ procedure TPasResolver.RaiseIdentifierNotFound(Identifier: string;
   El: TPasElement);
 begin
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.RaiseIdentifierNotFound START');
+  writeln('TPasResolver.RaiseIdentifierNotFound START "',Identifier,'"');
   WriteScopes;
   {$ENDIF}
   RaiseMsg(nIdentifierNotFound,sIdentifierNotFound,[Identifier],El);

packages/fcl-passrc/src/pastree.pp

@@ -334,14 +334,14 @@ type
     Filename   : String;  // the IN filename, only written when not empty.
   end;
 
-  { TPasProgram }
-
   { TPasUnitModule }
 
   TPasUnitModule = Class(TPasModule)
     function ElementTypeName: string; override;
   end;
 
+  { TPasProgram }
+
   TPasProgram = class(TPasModule)
   Public
     destructor Destroy; override;
@@ -689,7 +689,7 @@ type
     function ElementTypeName: string; override;
   end;
 
-  { TPasTypeRef }
+  { TPasTypeRef  - not used by TPasParser }
 
   TPasTypeRef = class(TPasUnresolvedTypeRef)
   public
@@ -984,7 +984,7 @@ Type
 
   TPasImplCommand = class(TPasImplElement)
   public
-    Command: string;
+    Command: string; // never set by TPasParser
   end;
 
   { TPasImplCommands - used by mkxmlrpc, not used by pparser }
@@ -1037,7 +1037,7 @@ Type
     function AddCaseOf(const Expression: TPasExpr): TPasImplCaseOf;
     function AddForLoop(AVar: TPasVariable;
       const AStartValue, AEndValue: TPasExpr): TPasImplForLoop;
-    function AddForLoop(const AVarName : String; AStartValue, AEndValue: TPasExpr;
+    function AddForLoop(AVarName : TPasExpr; AStartValue, AEndValue: TPasExpr;
       ADownTo: Boolean = false): TPasImplForLoop;
     function AddTry: TPasImplTry;
     function AddExceptOn(const VarName, TypeName: TPasExpr): TPasImplExceptOn;
@@ -1049,7 +1049,7 @@ Type
     procedure ForEachCall(const aMethodCall: TListCallback;
       const Arg: Pointer); override;
   public
-    Elements: TFPList;    // TPasImplElement objects
+    Elements: TFPList;    // list of TPasImplElement and maybe one TPasImplCaseElse
   end;
 
   { TPasImplStatement }
@@ -1156,7 +1156,7 @@ Type
       const Arg: Pointer); override;
   public
     CaseExpr : TPasExpr;
-    ElseBranch: TPasImplCaseElse;
+    ElseBranch: TPasImplCaseElse; // this is also in Elements
     function Expression: string;
   end;
 
@@ -1189,7 +1189,7 @@ Type
     procedure ForEachCall(const aMethodCall: TListCallback;
       const Arg: Pointer); override;
   public
-    VariableName : String;
+    VariableName : TPasExpr;
     LoopType : TLoopType;
     StartExpr : TPasExpr;
     EndExpr : TPasExpr;
@@ -1295,7 +1295,7 @@ Type
 
   TPasImplLabelMark = class(TPasImplElement)
   public
-    LabelId:  AnsiString;
+    LabelId: AnsiString;
   end;
 
 const
@@ -1363,10 +1363,19 @@ const
                    'static','inline','assembler','varargs', 'public',
                    'compilerproc','external','forward');
 
+procedure ReleaseAndNil(var El: TPasElement); overload;
+
 implementation
 
 uses SysUtils;
 
+procedure ReleaseAndNil(var El: TPasElement);
+begin
+  if El=nil then exit;
+  El.Release;
+  El:=nil;
+end;
+
 { TPasTypeRef }
 
 procedure TPasTypeRef.ForEachCall(const aMethodCall: TListCallback;
@@ -1410,8 +1419,8 @@ end;
 
 destructor TPasImplRaise.Destroy;
 begin
-  FreeAndNil(ExceptObject);
-  FreeAndNil(ExceptAddr);
+  ReleaseAndNil(TPasElement(ExceptObject));
+  ReleaseAndNil(TPasElement(ExceptAddr));
   Inherited;
 end;
 
@@ -1429,7 +1438,7 @@ end;
 
 destructor TPasImplRepeatUntil.Destroy;
 begin
-  FreeAndNil(ConditionExpr);
+  ReleaseAndNil(TPasElement(ConditionExpr));
   inherited Destroy;
 end;
 
@@ -1453,7 +1462,7 @@ end;
 
 destructor TPasImplSimple.Destroy;
 begin
-  FreeAndNil(Expr);
+  ReleaseAndNil(TPasElement(Expr));
   inherited Destroy;
 end;
 
@@ -1469,8 +1478,8 @@ end;
 
 destructor TPasImplAssign.Destroy;
 begin
-  FreeAndNil(Left);
-  FreeAndNil(Right);
+  ReleaseAndNil(TPasElement(Left));
+  ReleaseAndNil(TPasElement(Right));
   inherited Destroy;
 end;
 
@@ -1488,8 +1497,8 @@ end;
 
 destructor TPasExportSymbol.Destroy;
 begin
-  FreeAndNil(ExportName);
-  FreeAndNil(ExportIndex);
+  ReleaseAndNil(TPasElement(ExportName));
+  ReleaseAndNil(TPasElement(ExportIndex));
   inherited Destroy;
 end;
 
@@ -1528,7 +1537,7 @@ end;
 
 destructor TPasLibrary.Destroy;
 begin
-  FreeAndNil(LibrarySection);
+  ReleaseAndNil(TPasElement(LibrarySection));
   inherited Destroy;
 end;
 
@@ -1540,16 +1549,16 @@ end;
 procedure TPasLibrary.ForEachCall(const aMethodCall: TListCallback;
   const Arg: Pointer);
 begin
-  inherited ForEachCall(aMethodCall, Arg);
   if LibrarySection<>nil then
     LibrarySection.ForEachCall(aMethodCall,Arg);
+  inherited ForEachCall(aMethodCall, Arg);
 end;
 
 { TPasProgram }
 
 destructor TPasProgram.Destroy;
 begin
-  FreeAndNil(ProgramSection);
+  ReleaseAndNil(TPasElement(ProgramSection));
   inherited Destroy;
 end;
 
@@ -1561,9 +1570,9 @@ end;
 procedure TPasProgram.ForEachCall(const aMethodCall: TListCallback;
   const Arg: Pointer);
 begin
-  inherited ForEachCall(aMethodCall, Arg);
   if ProgramSection<>nil then
     ProgramSection.ForEachCall(aMethodCall,Arg);
+  inherited ForEachCall(aMethodCall, Arg);
 end;
 
 { TPasUnitModule }
@@ -1647,7 +1656,7 @@ end;
 
 destructor TPasEnumValue.Destroy;
 begin
-  FreeAndNil(Value);
+  ReleaseAndNil(TPasElement(Value));
   inherited Destroy;
 end;
 
@@ -1984,8 +1993,8 @@ begin
     InterfaceSection.Release;
   if Assigned(ImplementationSection) then
     ImplementationSection.Release;
-  FreeAndNil(InitializationSection);
-  FreeAndNil(FinalizationSection);
+  ReleaseAndNil(TPasElement(InitializationSection));
+  ReleaseAndNil(TPasElement(FinalizationSection));
   inherited Destroy;
 end;
 
@@ -2203,7 +2212,7 @@ begin
     AncestorType.Release;
   if Assigned(HelperForType) then
     HelperForType.Release;
-  FreeAndNil(GUIDExpr);
+  ReleaseAndNil(TPasElement(GUIDExpr));
   Modifiers.Free;
   Interfaces.Free;
   for i := 0 to GenericTemplateTypes.Count - 1 do
@@ -2307,9 +2316,8 @@ end;
 
 destructor TPasArgument.Destroy;
 begin
-  if Assigned(ArgType) then
-    ArgType.Release;
-  FreeAndNil(ValueExpr);
+  ReleaseAndNil(TPasElement(ArgType));
+  ReleaseAndNil(TPasElement(ValueExpr));
   inherited Destroy;
 end;
 
@@ -2390,10 +2398,8 @@ begin
 //  FreeAndNil(Expr);
   { Attention, in derived classes, VarType isn't necessarily set!
     (e.g. in Constants) }
-  if Assigned(VarType) then
-    VarType.Release;
-  if Assigned(Expr) then
-    Expr.Release;
+  ReleaseAndNil(TPasElement(VarType));
+  ReleaseAndNil(TPasElement(Expr));
   inherited Destroy;
 end;
 
@@ -2411,8 +2417,8 @@ begin
   for i := 0 to Args.Count - 1 do
     TPasArgument(Args[i]).Release;
   Args.Free;
-  FreeAndNil(DefaultExpr);
-  FreeAndNil(IndexExpr);
+  ReleaseAndNil(TPasElement(DefaultExpr));
+  ReleaseAndNil(TPasElement(IndexExpr));
   inherited Destroy;
 end;
 
@@ -2443,9 +2449,12 @@ end;
 
 procedure TPasOverloadedProc.ForEachCall(
   const aMethodCall: TListCallback; const Arg: Pointer);
+var
+  i: Integer;
 begin
   inherited ForEachCall(aMethodCall, Arg);
-  // Overloads are only references
+  for i:=0 to Overloads.Count-1 do
+    TPasProcedure(Overloads[i]).ForEachCall(aMethodCall,Arg);
 end;
 
 function TPasProcedure.GetCallingConvention: TCallingConvention;
@@ -2467,9 +2476,9 @@ begin
     ProcType.Release;
   if Assigned(Body) then
     Body.Release;
-  FreeAndNil(PublicName);
-  FreeAndNil(LibraryExpr);
-  FreeAndNil(LibrarySymbolName);
+  ReleaseAndNil(TPasElement(PublicName));
+  ReleaseAndNil(TPasElement(LibraryExpr));
+  ReleaseAndNil(TPasElement(LibrarySymbolName));
   inherited Destroy;
 end;
 
@@ -2533,11 +2542,9 @@ end;
 
 destructor TPasImplIfElse.Destroy;
 begin
-  FreeAndNil(ConditionExpr);
-  if Assigned(IfBranch) then
-    IfBranch.Release;
-  if Assigned(ElseBranch) then
-    ElseBranch.Release;
+  ReleaseAndNil(TPasElement(ConditionExpr));
+  ReleaseAndNil(TPasElement(IfBranch));
+  ReleaseAndNil(TPasElement(ElseBranch));
   inherited Destroy;
 end;
 
@@ -2583,12 +2590,11 @@ end;
 
 destructor TPasImplForLoop.Destroy;
 begin
-  FreeAndNil(StartExpr);
-  FreeAndNil(EndExpr);
-  if Assigned(Variable) then
-    Variable.Release;
-  if Assigned(Body) then
-    Body.Release;
+  ReleaseAndNil(TPasElement(VariableName));
+  ReleaseAndNil(TPasElement(StartExpr));
+  ReleaseAndNil(TPasElement(EndExpr));
+  ReleaseAndNil(TPasElement(Variable));
+  ReleaseAndNil(TPasElement(Body));
   inherited Destroy;
 end;
 
@@ -2608,6 +2614,8 @@ procedure TPasImplForLoop.ForEachCall(const aMethodCall: TListCallback;
   const Arg: Pointer);
 begin
   inherited ForEachCall(aMethodCall, Arg);
+  if VariableName<>nil then
+    VariableName.ForEachCall(aMethodCall,Arg);
   if Variable<>nil then
     Variable.ForEachCall(aMethodCall,Arg);
   if StartExpr<>nil then
@@ -2723,7 +2731,7 @@ begin
   AddElement(Result);
 end;
 
-function TPasImplBlock.AddForLoop(const AVarName: String; AStartValue,
+function TPasImplBlock.AddForLoop(AVarName: TPasExpr; AStartValue,
   AEndValue: TPasExpr; ADownTo: Boolean): TPasImplForLoop;
 begin
   Result := TPasImplForLoop.Create('', Self);
@@ -2916,7 +2924,7 @@ end;
 
 destructor TPasRangeType.Destroy;
 begin
-  FreeAndNil(RangeExpr);
+  ReleaseAndNil(TPasElement(RangeExpr));
   inherited Destroy;
 end;
 
@@ -3756,9 +3764,8 @@ end;
 
 destructor TPasImplWhileDo.Destroy;
 begin
-  FreeAndNil(ConditionExpr);
-  if Assigned(Body) then
-    Body.Release;
+  ReleaseAndNil(TPasElement(ConditionExpr));
+  ReleaseAndNil(TPasElement(Body));
   inherited Destroy;
 end;
 
@@ -3794,9 +3801,8 @@ end;
 
 destructor TPasImplCaseOf.Destroy;
 begin
-  FreeAndNil(CaseExpr);
-  if Assigned(ElseBranch) then
-    ElseBranch.Release;
+  ReleaseAndNil(TPasElement(CaseExpr));
+  ReleaseAndNil(TPasElement(ElseBranch));
   inherited Destroy;
 end;
 
@@ -3858,8 +3864,7 @@ begin
   For I:=0 to Expressions.Count-1 do
     TPasExpr(Expressions[i]).Release;
   FreeAndNil(Expressions);
-  if Assigned(Body) then
-    Body.Release;
+  ReleaseAndNil(TPasElement(Body));
   inherited Destroy;
 end;
 
@@ -3980,10 +3985,9 @@ end;
 
 destructor TPasImplExceptOn.Destroy;
 begin
-  FreeAndNil(VarExpr);
-  FreeAndNil(TypeExpr);
-  if Assigned(Body) then
-    Body.Release;
+  ReleaseAndNil(TPasElement(VarExpr));
+  ReleaseAndNil(TPasElement(TypeExpr));
+  ReleaseAndNil(TPasElement(Body));
   inherited Destroy;
 end;
 
@@ -4236,7 +4240,7 @@ destructor TParamsExpr.Destroy;
 var
   i : Integer;
 begin
-  FreeAndNil(Value);
+  ReleaseAndNil(TPasElement(Value));
   for i:=0 to length(Params)-1 do Params[i].Release;
   inherited Destroy;
 end;

packages/fcl-passrc/src/pscanner.pp

@@ -317,6 +317,7 @@ type
     function FindSourceFile(const AName: string): TLineReader; override;
     function FindIncludeFile(const AName: string): TLineReader; override;
     Property OwnsStreams : Boolean Read FOwnsStreams write SetOwnsStreams;
+    Property Streams: TStringList read FStreams;
   end;
 
   EScannerError       = class(Exception);
@@ -331,6 +332,13 @@ type
     );
   TPOptions = set of TPOption;
 
+type
+  TPasSourcePos = Record
+    FileName: String;
+    Row, Column: Cardinal;
+  end;
+
+type
   { TPascalScanner }
 
   TPScannerLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
@@ -394,6 +402,7 @@ type
     function FetchToken: TToken;
     Procedure AddDefine(S : String);
     Procedure RemoveDefine(S : String);
+    function CurSourcePos: TPasSourcePos;
 
     property FileResolver: TBaseFileResolver read FFileResolver;
     property CurSourceFile: TLineReader read FCurSourceFile;
@@ -755,7 +764,7 @@ begin
     While (I=-1) and (J<IncludePaths.Count-1) do
       begin
       FN:=IncludeTrailingPathDelimiter(IncludePaths[i])+AName;
-      I:=FStreams.INdexOf(FN);
+      I:=FStreams.IndexOf(FN);
       Inc(J);
       end;
     end;
@@ -1954,4 +1963,11 @@ begin
     FDefines.Delete(I);
 end;
 
+function TPascalScanner.CurSourcePos: TPasSourcePos;
+begin
+  Result.FileName:=CurFilename;
+  Result.Row:=CurRow;
+  Result.Column:=CurColumn;
+end;
+
 end.

packages/fcl-passrc/tests/tcbaseparser.pas

@@ -100,6 +100,8 @@ Type
 
 function ExtractFileUnitName(aFilename: string): string;
 function GetPasElementDesc(El: TPasElement): string;
+procedure ReadNextPascalToken(var Position: PChar; out TokenStart: PChar;
+  NestedComments: boolean; SkipDirectives: boolean);
 
 implementation
 
@@ -128,6 +130,263 @@ begin
   Result:=El.Name+':'+El.ClassName+'['+El.SourceFilename+','+IntToStr(El.SourceLinenumber)+']';
 end;
 
+procedure ReadNextPascalToken(var Position: PChar; out TokenStart: PChar;
+  NestedComments: boolean; SkipDirectives: boolean);
+const
+  IdentChars = ['a'..'z','A'..'Z','_','0'..'9'];
+  HexNumberChars = ['0'..'9','a'..'f','A'..'F'];
+var
+  c1:char;
+  CommentLvl: Integer;
+  Src: PChar;
+begin
+  Src:=Position;
+  // read till next atom
+  while true do
+    begin
+    case Src^ of
+    #0: break;
+    #1..#32:  // spaces and special characters
+      inc(Src);
+    #$EF:
+      if (Src[1]=#$BB)
+      and (Src[2]=#$BF) then
+        begin
+        // skip UTF BOM
+        inc(Src,3);
+        end
+      else
+        break;
+    '{':    // comment start or compiler directive
+      if (Src[1]='$') and (not SkipDirectives) then
+        // compiler directive
+        break
+      else begin
+        // Pascal comment => skip
+        CommentLvl:=1;
+        while true do
+          begin
+          inc(Src);
+          case Src^ of
+          #0: break;
+          '{':
+            if NestedComments then
+              inc(CommentLvl);
+          '}':
+            begin
+            dec(CommentLvl);
+            if CommentLvl=0 then
+              begin
+              inc(Src);
+              break;
+              end;
+            end;
+          end;
+        end;
+      end;
+    '/':  // comment or real division
+      if (Src[1]='/') then
+        begin
+        // comment start -> read til line end
+        inc(Src);
+        while not (Src^ in [#0,#10,#13]) do
+          inc(Src);
+        end
+      else
+        break;
+    '(':  // comment, bracket or compiler directive
+      if (Src[1]='*') then
+        begin
+        if (Src[2]='$') and (not SkipDirectives) then
+          // compiler directive
+          break
+        else
+          begin
+          // comment start -> read til comment end
+          inc(Src,2);
+          CommentLvl:=1;
+          while true do
+            begin
+            case Src^ of
+            #0: break;
+            '(':
+              if NestedComments and (Src[1]='*') then
+                inc(CommentLvl);
+            '*':
+              if (Src[1]=')') then
+                begin
+                dec(CommentLvl);
+                if CommentLvl=0 then
+                  begin
+                  inc(Src,2);
+                  break;
+                  end;
+                inc(Position);
+                end;
+            end;
+            inc(Src);
+            end;
+        end;
+      end else
+        // round bracket open
+        break;
+    else
+      break;
+    end;
+    end;
+  // read token
+  TokenStart:=Src;
+  c1:=Src^;
+  case c1 of
+  #0:
+    ;
+  'A'..'Z','a'..'z','_':
+    begin
+    // identifier
+    inc(Src);
+    while Src^ in IdentChars do
+      inc(Src);
+    end;
+  '0'..'9': // number
+    begin
+    inc(Src);
+    // read numbers
+    while (Src^ in ['0'..'9']) do
+      inc(Src);
+    if (Src^='.') and (Src[1]<>'.') then
+      begin
+      // real type number
+      inc(Src);
+      while (Src^ in ['0'..'9']) do
+        inc(Src);
+      end;
+    if (Src^ in ['e','E']) then
+      begin
+      // read exponent
+      inc(Src);
+      if (Src^='-') then inc(Src);
+      while (Src^ in ['0'..'9']) do
+        inc(Src);
+      end;
+    end;
+  '''','#':  // string constant
+    while true do
+      case Src^ of
+      #0: break;
+      '#':
+        begin
+        inc(Src);
+        while Src^ in ['0'..'9'] do
+          inc(Src);
+        end;
+      '''':
+        begin
+        inc(Src);
+        while not (Src^ in ['''',#0]) do
+          inc(Src);
+        if Src^='''' then
+          inc(Src);
+        end;
+      else
+        break;
+      end;
+  '$':  // hex constant
+    begin
+    inc(Src);
+    while Src^ in HexNumberChars do
+      inc(Src);
+    end;
+  '&':  // octal constant or keyword as identifier (e.g. &label)
+    begin
+    inc(Src);
+    if Src^ in ['0'..'7'] then
+      while Src^ in ['0'..'7'] do
+        inc(Src)
+    else
+      while Src^ in IdentChars do
+        inc(Src);
+    end;
+  '{':  // compiler directive (it can't be a comment, because see above)
+    begin
+    CommentLvl:=1;
+    while true do
+      begin
+      inc(Src);
+      case Src^ of
+      #0: break;
+      '{':
+        if NestedComments then
+          inc(CommentLvl);
+      '}':
+        begin
+        dec(CommentLvl);
+        if CommentLvl=0 then
+          begin
+          inc(Src);
+          break;
+          end;
+        end;
+      end;
+      end;
+    end;
+  '(':  // bracket or compiler directive
+    if (Src[1]='*') then
+      begin
+      // compiler directive -> read til comment end
+      inc(Src,2);
+      while (Src^<>#0) and ((Src^<>'*') or (Src[1]<>')')) do
+        inc(Src);
+      inc(Src,2);
+      end
+    else
+      // round bracket open
+      inc(Src);
+  #192..#255:
+    begin
+    // read UTF8 character
+    inc(Src);
+    if ((ord(c1) and %11100000) = %11000000) then
+      begin
+      // could be 2 byte character
+      if (ord(Src[0]) and %11000000) = %10000000 then
+        inc(Src);
+      end
+    else if ((ord(c1) and %11110000) = %11100000) then
+      begin
+      // could be 3 byte character
+      if ((ord(Src[0]) and %11000000) = %10000000)
+      and ((ord(Src[1]) and %11000000) = %10000000) then
+        inc(Src,2);
+      end
+    else if ((ord(c1) and %11111000) = %11110000) then
+      begin
+      // could be 4 byte character
+      if ((ord(Src[0]) and %11000000) = %10000000)
+      and ((ord(Src[1]) and %11000000) = %10000000)
+      and ((ord(Src[2]) and %11000000) = %10000000) then
+        inc(Src,3);
+      end;
+    end;
+  else
+    inc(Src);
+    case c1 of
+    '<': if Src^ in ['>','='] then inc(Src);
+    '.': if Src^='.' then inc(Src);
+    '@':
+      if Src^='@' then
+        begin
+        // @@ label
+        repeat
+          inc(Src);
+        until not (Src^ in IdentChars);
+        end
+    else
+      if (Src^='=') and (c1 in [':','+','-','/','*','<','>']) then
+        inc(Src);
+    end;
+  end;
+  Position:=Src;
+end;
 
 { TTestEngine }
 
@@ -386,6 +645,7 @@ end;
 function TTestParser.AssertExpression(const Msg: String; AExpr: TPasExpr;
   aKind: TPasExprKind; AClass: TClass): TPasExpr;
 begin
+  AssertNotNull(AExpr);
   AssertEquals(Msg+': Correct expression kind',aKind,AExpr.Kind);
   AssertEquals(Msg+': Correct expression class',AClass,AExpr.ClassType);
   Result:=AExpr;

packages/fcl-passrc/tests/tcresolver.pas

@@ -2,6 +2,15 @@
   Examples:
     ./testpassrc --suite=TTestResolver.TestEmpty
 }
+(*
+  CheckReferenceDirectives:
+    {#a} label "a", labels all elements at the following token
+    {@a} reference "a", search at next token for an element e with
+           TResolvedReference(e.CustomData).Declaration points to an element
+           labeled "a".
+    {=a} is "a", search at next token for a TPasAliasType t with t.DestType
+           points to an element labeled "a"
+*)
 unit tcresolver;
 
 {$mode objfpc}{$H+}
@@ -40,6 +49,15 @@ Type
     property Module: TPasModule read FModule write SetModule;
   end;
 
+  TTestResolverReferenceData = record
+    Filename: string;
+    Line: integer;
+    StartCol: integer;
+    EndCol: integer;
+    Found: TFPList; // list of TPasElement at this token
+  end;
+  PTestResolverReferenceData = ^TTestResolverReferenceData;
+
   { TTestResolver }
 
   TTestResolver = Class(TTestParser)
@@ -50,12 +68,14 @@ Type
     function GetModuleCount: integer;
     function GetModules(Index: integer): TTestEnginePasResolver;
     function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
+    procedure OnFindReference(Element, FindData: pointer);
   Protected
     Procedure SetUp; override;
     Procedure TearDown; override;
     procedure CreateEngine(var TheEngine: TPasTreeContainer); override;
     procedure ParseProgram;
     procedure ParseUnit;
+    procedure CheckReferenceDirectives;
   Public
     function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver;
     function AddModule(aFilename: string): TTestEnginePasResolver;
@@ -71,17 +91,24 @@ Type
     Procedure TestEmpty;
     Procedure TestAliasType;
     Procedure TestAlias2Type;
+    Procedure TestAliasTypeRefs;
     Procedure TestVarLongint;
     Procedure TestVarInteger;
     Procedure TestConstInteger;
     Procedure TestPrgAssignment;
     Procedure TestPrgProcVar;
     Procedure TestUnitProcVar;
+    Procedure TestForLoop;
     Procedure TestStatements;
+    Procedure TestCaseStatement;
+    Procedure TestTryStatement;
+    Procedure TestStatementsRefs;
     Procedure TestUnitRef;
     Procedure TestProcParam;
     Procedure TestFunctionResult;
     Procedure TestProcOverload;
+    Procedure TestProcOverloadRefs;
+    Procedure TestNestedProc;
     property PasResolver: TTestEnginePasResolver read FPasResolver;
   end;
 
@@ -124,6 +151,7 @@ end;
 constructor TTestEnginePasResolver.Create;
 begin
   inherited Create;
+  StoreSrcColumns:=true;
 end;
 
 destructor TTestEnginePasResolver.Destroy;
@@ -211,6 +239,7 @@ begin
   if (PasProgram.InitializationSection.Elements.Count>0) then
     if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
       FFirstStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
+  CheckReferenceDirectives;
 end;
 
 procedure TTestResolver.ParseUnit;
@@ -253,6 +282,411 @@ begin
   and (Module.InitializationSection.Elements.Count>0) then
     if TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock then
       FFirstStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
+  CheckReferenceDirectives;
+end;
+
+procedure TTestResolver.CheckReferenceDirectives;
+type
+  TMarkerKind = (
+    mkLabel,
+    mkResolverReference,
+    mkDirectReference
+    );
+  PMarker = ^TMarker;
+  TMarker = record
+    Kind: TMarkerKind;
+    Filename: string;
+    LineNumber: integer;
+    StartCol, EndCol: integer; // token start, end column
+    Identifier: string;
+    Next: PMarker;
+  end;
+
+var
+  FirstMarker, LastMarker: PMarker;
+  Filename: string;
+  LineNumber: Integer;
+  SrcLine: String;
+  CommentStartP, CommentEndP: PChar;
+  FoundRefs: TTestResolverReferenceData;
+
+  procedure GetSrc(Index: integer; out SrcLines: TStringList; out aFilename: string);
+  var
+    aStream: TStream;
+  begin
+    SrcLines:=TStringList.Create;
+    aStream:=Resolver.Streams.Objects[Index] as TStream;
+    aStream.Position:=0;
+    SrcLines.LoadFromStream(aStream);
+    aFilename:=Resolver.Streams[Index];
+  end;
+
+  procedure RaiseErrorAt(Msg: string; const aFilename: string; aLine, aCol: integer);
+  var
+    s, SrcFilename: String;
+    i, j: Integer;
+    SrcLines: TStringList;
+  begin
+    // write all source files
+    for i:=0 to Resolver.Streams.Count-1 do
+      begin
+      GetSrc(i,SrcLines,SrcFilename);
+      writeln('Testcode:-File="',SrcFilename,'"----------------------------------:');
+      for j:=1 to SrcLines.Count do
+        writeln(Format('%:4d: ',[j]),SrcLines[j-1]);
+      SrcLines.Free;
+      end;
+    s:=Msg+' at '+aFilename+' line='+IntToStr(aLine)+', col='+IntToStr(aCol);
+    writeln('ERROR: TTestResolver.CheckReferenceDirectives: ',s);
+    raise Exception.Create('TTestResolver.CheckReferenceDirectives: '+s);
+  end;
+
+  procedure RaiseErrorAt(Msg: string; aMarker: PMarker);
+  begin
+    RaiseErrorAt(Msg,aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol);
+  end;
+
+  procedure RaiseError(Msg: string; p: PChar);
+  begin
+    RaiseErrorAt(Msg,Filename,LineNumber,p-PChar(SrcLine)+1);
+  end;
+
+  procedure AddMarker(Marker: PMarker);
+  begin
+    if LastMarker<>nil then
+      LastMarker^.Next:=Marker
+    else
+      FirstMarker:=Marker;
+    LastMarker:=Marker;
+  end;
+
+  function AddMarker(Kind: TMarkerKind; const aFilename: string;
+    aLine, aStartCol, aEndCol: integer; const Identifier: string): PMarker;
+  begin
+    New(Result);
+    Result^.Kind:=Kind;
+    Result^.Filename:=aFilename;
+    Result^.LineNumber:=aLine;
+    Result^.StartCol:=aStartCol;
+    Result^.EndCol:=aEndCol;
+    Result^.Identifier:=Identifier;
+    Result^.Next:=nil;
+    //writeln('AddMarker Line="',SrcLine,'" Identifier=',Identifier,' Col=',aStartCol,'-',aEndCol,' "',copy(SrcLine,aStartCol,aEndCol-aStartCol),'"');
+    AddMarker(Result);
+  end;
+
+  function AddMarkerForTokenBehindComment(Kind: TMarkerKind;
+    const Identifer: string): PMarker;
+  var
+    TokenStart, p: PChar;
+  begin
+    p:=CommentEndP;
+    ReadNextPascalToken(p,TokenStart,false,false);
+    Result:=AddMarker(Kind,Filename,LineNumber,
+      CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifer);
+  end;
+
+  function FindLabel(const Identifier: string): PMarker;
+  begin
+    Result:=FirstMarker;
+    while Result<>nil do
+      begin
+      if (Result^.Kind=mkLabel)
+      and (CompareText(Result^.Identifier,Identifier)=0) then
+        exit;
+      Result:=Result^.Next;
+      end;
+  end;
+
+  function ReadIdentifier(var p: PChar): string;
+  var
+    StartP: PChar;
+  begin
+    if not (p^ in ['a'..'z','A'..'Z','_']) then
+      RaiseError('identifier expected',p);
+    StartP:=p;
+    inc(p);
+    while p^ in ['a'..'z','A'..'Z','_','0'..'9'] do inc(p);
+    SetLength(Result,p-StartP);
+    Move(StartP^,Result[1],length(Result));
+  end;
+
+  procedure AddLabel;
+  var
+    Identifier: String;
+    p: PChar;
+  begin
+    p:=CommentStartP+2;
+    Identifier:=ReadIdentifier(p);
+    //writeln('TTestResolver.CheckReferenceDirectives.AddLabel ',Identifier);
+    if FindLabel(Identifier)<>nil then
+      RaiseError('duplicate label "'+Identifier+'"',p);
+    AddMarkerForTokenBehindComment(mkLabel,Identifier);
+  end;
+
+  procedure AddResolverReference;
+  var
+    Identifier: String;
+    p: PChar;
+  begin
+    p:=CommentStartP+2;
+    Identifier:=ReadIdentifier(p);
+    //writeln('TTestResolver.CheckReferenceDirectives.AddReference ',Identifier);
+    AddMarkerForTokenBehindComment(mkResolverReference,Identifier);
+  end;
+
+  procedure AddDirectReference;
+  var
+    Identifier: String;
+    p: PChar;
+  begin
+    p:=CommentStartP+2;
+    Identifier:=ReadIdentifier(p);
+    //writeln('TTestResolver.CheckReferenceDirectives.AddPointer ',Identifier);
+    AddMarkerForTokenBehindComment(mkDirectReference,Identifier);
+  end;
+
+  procedure ParseCode(SrcLines: TStringList; aFilename: string);
+  var
+    p: PChar;
+    IsDirective: Boolean;
+  begin
+    //writeln('TTestResolver.CheckReferenceDirectives.ParseCode File=',aFilename);
+    Filename:=aFilename;
+    // parse code, find all labels
+    LineNumber:=0;
+    while LineNumber<SrcLines.Count do
+      begin
+      inc(LineNumber);
+      SrcLine:=SrcLines[LineNumber-1];
+      if SrcLine='' then continue;
+      //writeln('TTestResolver.CheckReferenceDirectives Line=',SrcLine);
+      p:=PChar(SrcLine);
+      repeat
+        case p^ of
+          #0: if (p-PChar(SrcLine)=length(SrcLine)) then break;
+          '{':
+            begin
+            CommentStartP:=p;
+            inc(p);
+            IsDirective:=p^ in ['#','@','='];
+
+            // skip to end of comment
+            repeat
+              case p^ of
+              #0:
+                if (p-PChar(SrcLine)=length(SrcLine)) then
+                  begin
+                  // multi line comment
+                  if IsDirective then
+                    RaiseError('directive missing closing bracket',CommentStartP);
+                  repeat
+                    inc(LineNumber);
+                    if LineNumber>SrcLines.Count then exit;
+                    SrcLine:=SrcLines[LineNumber-1];
+                    //writeln('TTestResolver.CheckReferenceDirectives Comment Line=',SrcLine);
+                  until SrcLine<>'';
+                  p:=PChar(SrcLine);
+                  continue;
+                  end;
+              '}':
+                begin
+                inc(p);
+                break;
+                end;
+              end;
+              inc(p);
+            until false;
+
+            CommentEndP:=p;
+            case CommentStartP[1] of
+            '#': AddLabel;
+            '@': AddResolverReference;
+            '=': AddDirectReference;
+            end;
+            p:=CommentEndP;
+            continue;
+
+            end;
+          '/':
+            if p[1]='/' then
+              break; // rest of line is comment -> skip
+        end;
+        inc(p);
+      until false;
+      end;
+  end;
+
+  function FindElementsAt(aFilename: string; aLine, aStartCol, aEndCol: integer): TFPList;
+  var
+    ok: Boolean;
+  begin
+    FoundRefs.Filename:=aFilename;
+    FoundRefs.Line:=aLine;
+    FoundRefs.StartCol:=aStartCol;
+    FoundRefs.EndCol:=aEndCol;
+    FoundRefs.Found:=TFPList.Create;
+    ok:=false;
+    try
+      Module.ForEachCall(@OnFindReference,@FoundRefs);
+      ok:=true;
+    finally
+      if not ok then
+        FreeAndNil(FoundRefs.Found);
+    end;
+    Result:=FoundRefs.Found;
+    FoundRefs.Found:=nil;
+  end;
+
+  procedure CheckResolverReference(aMarker: PMarker);
+  // check if one element at {@a} has a TResolvedReference to an element labeled {#a}
+  var
+    aLabel: PMarker;
+    ReferenceElements, LabelElements: TFPList;
+    i, j, aLine, aCol: Integer;
+    El, LabelEl: TPasElement;
+    Ref: TResolvedReference;
+  begin
+    //writeln('CheckReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"');
+    aLabel:=FindLabel(aMarker^.Identifier);
+    if aLabel=nil then
+      RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol);
+
+    LabelElements:=nil;
+    ReferenceElements:=nil;
+    try
+      LabelElements:=FindElementsAt(aLabel^.Filename,aLabel^.LineNumber,aLabel^.StartCol,aLabel^.EndCol);
+      if LabelElements.Count=0 then
+        RaiseErrorAt('label "'+aLabel^.Identifier+'" has no elements',aLabel);
+
+      ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol);
+      if ReferenceElements.Count=0 then
+        RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker);
+
+      for i:=0 to ReferenceElements.Count-1 do
+        begin
+        El:=TPasElement(ReferenceElements[i]);
+        if El.CustomData is TResolvedReference then
+          begin
+          Ref:=TResolvedReference(El.CustomData);
+          for j:=0 to LabelElements.Count-1 do
+            begin
+            LabelEl:=TPasElement(LabelElements[j]);
+            if Ref.Declaration=LabelEl then
+              exit; // success
+            end;
+          end;
+        end;
+
+      // failure write candidates
+      for i:=0 to ReferenceElements.Count-1 do
+        begin
+        El:=TPasElement(ReferenceElements[i]);
+        write('Reference candidate for "',aMarker^.Identifier,'" at reference ',aMarker^.Filename,'(',aMarker^.LineNumber,',',aMarker^.StartCol,'-',aMarker^.EndCol,')');
+        write(' El=',GetObjName(El));
+        if El.CustomData is TResolvedReference then
+          begin
+          Ref:=TResolvedReference(El.CustomData);
+          write(' Decl=',GetObjName(Ref.Declaration));
+          PasResolver.UnmangleSourceLineNumber(Ref.Declaration.SourceLinenumber,aLine,aCol);
+          write(Ref.Declaration.SourceFilename,'(',aLine,',',aCol,')');
+          end
+        else
+          write(' has no TResolvedReference');
+        writeln;
+        end;
+      for i:=0 to LabelElements.Count-1 do
+        begin
+        El:=TPasElement(LabelElements[i]);
+        write('Label candidate for "',aLabel^.Identifier,'" at reference ',aLabel^.Filename,'(',aLabel^.LineNumber,',',aLabel^.StartCol,'-',aLabel^.EndCol,')');
+        write(' El=',GetObjName(El));
+        writeln;
+        end;
+
+      RaiseErrorAt('wrong resolved reference "'+aMarker^.Identifier+'"',aMarker);
+    finally
+      LabelElements.Free;
+      ReferenceElements.Free;
+    end;
+  end;
+
+  procedure CheckDirectReference(aMarker: PMarker);
+  // check if one element at {=a} is a TPasAliasType pointing to an element labeled {#a}
+  var
+    aLabel: PMarker;
+    ReferenceElements: TFPList;
+    i, LabelLine, LabelCol: Integer;
+    El: TPasElement;
+    DeclEl: TPasType;
+  begin
+    //writeln('CheckPointer searching pointer: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"');
+    aLabel:=FindLabel(aMarker^.Identifier);
+    if aLabel=nil then
+      RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol);
+
+    ReferenceElements:=nil;
+    try
+      ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol);
+      if ReferenceElements.Count=0 then
+        RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker);
+
+      for i:=0 to ReferenceElements.Count-1 do
+        begin
+        El:=TPasElement(ReferenceElements[i]);
+        if El.ClassType=TPasAliasType then
+          begin
+          DeclEl:=TPasAliasType(El).DestType;
+          PasResolver.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
+          if (aLabel^.Filename=DeclEl.SourceFilename)
+          and (aLabel^.LineNumber=LabelLine)
+          and (aLabel^.StartCol<=LabelCol)
+          and (aLabel^.EndCol>=LabelCol) then
+            exit; // success
+          writeln('CheckDirectReference Decl at ',DeclEl.SourceFilename,'(',LabelLine,',',LabelCol,')');
+          RaiseErrorAt('wrong direct reference "'+aMarker^.Identifier+'"',aMarker);
+          end;
+        end;
+    finally
+    end;
+
+  end;
+
+var
+  aMarker: PMarker;
+  i: Integer;
+  SrcLines: TStringList;
+begin
+  FirstMarker:=nil;
+  LastMarker:=nil;
+  FoundRefs:=Default(TTestResolverReferenceData);
+  try
+    // find all markers
+    for i:=0 to Resolver.Streams.Count-1 do
+      begin
+      GetSrc(i,SrcLines,Filename);
+      ParseCode(SrcLines,Filename);
+      SrcLines.Free;
+      end;
+
+    // check references
+    aMarker:=FirstMarker;
+    while aMarker<>nil do
+      begin
+      case aMarker^.Kind of
+      mkResolverReference: CheckResolverReference(aMarker);
+      mkDirectReference: CheckDirectReference(aMarker);
+      end;
+      aMarker:=aMarker^.Next;
+      end;
+
+  finally
+    while FirstMarker<>nil do
+      begin
+      aMarker:=FirstMarker;
+      FirstMarker:=FirstMarker^.Next;
+      Dispose(aMarker);
+      end;
+  end;
 end;
 
 function TTestResolver.FindModuleWithFilename(aFilename: string
@@ -401,6 +835,22 @@ begin
   raise Exception.Create('can''t find unit "'+aUnitName+'"');
 end;
 
+procedure TTestResolver.OnFindReference(Element, FindData: pointer);
+var
+  El: TPasElement absolute Element;
+  Data: PTestResolverReferenceData absolute FindData;
+  Line, Col: integer;
+begin
+  PasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
+  //writeln('TTestResolver.OnFindReference ',GetObjName(El),' ',El.SourceFilename,' Line=',Line,',Col=',Col,' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol);
+  if (Data^.Filename=El.SourceFilename)
+  and (Data^.Line=Line)
+  and (Data^.StartCol<=Col)
+  and (Data^.EndCol>=Col)
+  then
+    Data^.Found.Add(El);
+end;
+
 function TTestResolver.GetModules(Index: integer): TTestEnginePasResolver;
 begin
   Result:=TTestEnginePasResolver(FModules[Index]);
@@ -469,6 +919,19 @@ begin
   AssertEquals('points to tint1','tint1',DestT2.Name);
 end;
 
+procedure TTestResolver.TestAliasTypeRefs;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  {#a}a=longint;');
+  Add('  {#b}{=a}b=a;');
+  Add('var');
+  Add('  {=a}c: a;');
+  Add('  {=b}d: b;');
+  Add('begin');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestVarLongint;
 var
   El: TPasElement;
@@ -662,6 +1125,18 @@ begin
   AssertSame('proc sub var type is proc sub t1',ProcSubType1,ProcSubVar1Type);
 end;
 
+procedure TTestResolver.TestForLoop;
+begin
+  StartProgram(false);
+  Add('var');
+  Add('  {#v1}v1,{#v2}v2,{#v3}v3:longint;');
+  Add('begin');
+  Add('  for {@v1}v1:=');
+  Add('    {@v2}v2');
+  Add('    to {@v3}v3 do ;');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestStatements;
 begin
   StartProgram(false);
@@ -682,6 +1157,86 @@ begin
   AssertEquals('3 declarations',3,PasProgram.ProgramSection.Declarations.Count);
 end;
 
+procedure TTestResolver.TestCaseStatement;
+begin
+  StartProgram(false);
+  Add('const');
+  Add('  {#c1}c1=1;');
+  Add('  {#c2}c2=1;');
+  Add('var');
+  Add('  {#v1}v1,{#v2}v2,{#v3}v3:longint;');
+  Add('begin');
+  Add('  Case {@v1}v1+{@v2}v2 of');
+  Add('  {@c1}c1:');
+  Add('    {@v2}v2:={@v3}v3;');
+  Add('  {@c1}c1,{@c2}c2: ;');
+  Add('  {@c1}c1..{@c2}c2: ;');
+  Add('  {@c1}c1+{@c2}c2: ;');
+  Add('  else');
+  Add('    {@v1}v1:=3;');
+  Add('  end;');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTryStatement;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  {#Exec}Exception = longint;');
+  Add('var');
+  Add('  {#v1}v1,{#e1}e:longint;');
+  Add('begin');
+  Add('  try');
+  Add('    {@v1}v1:={@e1}e;');
+  Add('  finally');
+  Add('    {@v1}v1:={@e1}e;');
+  Add('  end');
+  Add('  try');
+  Add('    {@v1}v1:={@e1}e;');
+  Add('  except');
+  Add('    {@v1}v1:={@e1}e;');
+  Add('  end');
+  Add('  try');
+  Add('    {@v1}v1:={@e1}e;');
+  Add('  except');
+  Add('    on {#e2}E: {@Exec}Exception do');
+  Add('      if {@e2}e=nil then ;');
+  Add('    on {#e3}E: {@Exec}Exception do');
+  Add('      raise {@e3}e;');
+  Add('    else');
+  Add('      {@v1}v1:={@e1}e;');
+  Add('  end');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestStatementsRefs;
+begin
+  StartProgram(false);
+  Add('var');
+  Add('  {#v1}v1,{#v2}v2,{#v3}v3:longint;');
+  Add('begin');
+  Add('  {@v1}v1:=1;');
+  Add('  {@v2}v2:=');
+  Add('    {@v1}v1+');
+  Add('    {@v1}v1*{@v1}v1');
+  Add('    +{@v1}v1 div {@v1}v1;');
+  Add('  {@v3}v3:=');
+  Add('    -{@v1}v1;');
+  Add('  repeat');
+  Add('    {@v1}v1:=');
+  Add('      {@v1}v1+1;');
+  Add('  until {@v1}v1>=5;');
+  Add('  while {@v1}v1>=0 do');
+  Add('    {@v1}v1');
+  Add('    :={@v1}v1-{@v2}v2;');
+  Add('  if {@v1}v1<{@v2}v2 then');
+  Add('    {@v3}v3:={@v1}v1');
+  Add('  else {@v3}v3:=');
+  Add('    {@v2}v2;');
+  ParseProgram;
+  AssertEquals('3 declarations',3,PasProgram.ProgramSection.Declarations.Count);
+end;
+
 procedure TTestResolver.TestUnitRef;
 var
   El, DeclEl, OtherUnit: TPasElement;
@@ -799,6 +1354,8 @@ begin
 end;
 
 procedure TTestResolver.TestProcOverload;
+var
+  El: TPasElement;
 begin
   StartProgram(false);
   Add('function Func1(i: longint; j: longint = 0): longint; overload;');
@@ -812,6 +1369,52 @@ begin
   Add('begin');
   Add('  Func1(3);');
   ParseProgram;
+  AssertEquals('1 declarations',1,PasProgram.ProgramSection.Declarations.Count);
+
+  El:=TPasElement(PasProgram.ProgramSection.Declarations[0]);
+  AssertEquals('overloaded proc',TPasOverloadedProc,El.ClassType);
+
+  AssertEquals('1 statement',1,PasProgram.InitializationSection.Elements.Count);
+end;
+
+procedure TTestResolver.TestProcOverloadRefs;
+begin
+  StartProgram(false);
+  Add('function {#A}Func1(i: longint; j: longint = 0): longint; overload;');
+  Add('begin');
+  Add('  Result:=1;');
+  Add('end;');
+  Add('function {#B}Func1(s: string): longint; overload;');
+  Add('begin');
+  Add('  Result:=2;');
+  Add('end;');
+  Add('begin');
+  Add('  {@A}Func1(3);');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestNestedProc;
+begin
+  StartProgram(false);
+  Add('function DoIt({#a1}a,{#d1}d: longint): longint;');
+  Add('var');
+  Add('  {#b1}b: longint;');
+  Add('  {#c1}c: longint;');
+  Add('  function {#Nesty1}Nesty({#a2}a: longint): longint; ');
+  Add('  var {#b2}b: longint;');
+  Add('  begin');
+  Add('    Result:={@a2}a');
+  Add('      +{@b2}b');
+  Add('      +{@c1}c');
+  Add('      +{@d1}d;');
+  Add('  end;');
+  Add('begin');
+  Add('  Result:={@a1}a');
+  Add('      +{@b1}b');
+  Add('      +{@c1}c;');
+  Add('end;');
+  Add('begin');
+  ParseProgram;
 end;
 
 initialization

packages/fcl-passrc/tests/tcstatements.pas

@@ -663,7 +663,7 @@ begin
   DeclareVar('integer');
   TestStatement(['For a:=1 to 10 do',';']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Loop type',ltNormal,F.Looptype);
   AssertEquals('Up loop',False,F.Down);
   AssertExpression('Start value',F.StartExpr,pekNumber,'1');
@@ -680,7 +680,7 @@ begin
   DeclareVar('integer');
   TestStatement(['For a in SomeSet Do',';']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Loop type',ltIn,F.Looptype);
   AssertEquals('In loop',False,F.Down);
   AssertExpression('Start value',F.StartExpr,pekIdent,'SomeSet');
@@ -697,7 +697,7 @@ begin
   DeclareVar('integer');
   TestStatement(['For a:=1+1 to 5+5 do',';']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Up loop',False,F.Down);
   AssertExpression('Start expression',F.StartExpr,pekBinary,TBinaryExpr);
   B:=F.StartExpr as TBinaryExpr;
@@ -719,7 +719,7 @@ begin
   DeclareVar('integer');
   TestStatement(['For a:=1 to 10 do','begin','end']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Up loop',False,F.Down);
   AssertExpression('Start value',F.StartExpr,pekNumber,'1');
   AssertExpression('End value',F.EndExpr,pekNumber,'10');
@@ -737,7 +737,7 @@ begin
   DeclareVar('integer');
   TestStatement(['For a:=10 downto 1 do','begin','end']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Down loop',True,F.Down);
   AssertExpression('Start value',F.StartExpr,pekNumber,'10');
   AssertExpression('End value',F.EndExpr,pekNumber,'1');
@@ -755,14 +755,14 @@ begin
   DeclareVar('integer','b');
   TestStatement(['For a:=1 to 10 do','For b:=11 to 20 do','begin','end']);
   F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
-  AssertEquals('Loop variable name','a',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
   AssertEquals('Up loop',False,F.Down);
   AssertExpression('Start value',F.StartExpr,pekNumber,'1');
   AssertExpression('End value',F.EndExpr,pekNumber,'10');
   AssertNotNull('Have while body',F.Body);
   AssertEquals('begin end block',TPasImplForLoop,F.Body.ClassType);
   F:=F.Body as TPasImplForLoop;
-  AssertEquals('Loop variable name','b',F.VariableName);
+  AssertExpression('Loop variable name',F.VariableName,pekIdent,'b');
   AssertEquals('Up loop',False,F.Down);
   AssertExpression('Start value',F.StartExpr,pekNumber,'11');
   AssertExpression('End value',F.EndExpr,pekNumber,'20');

packages/fcl-passrc/tests/tctypeparser.pas

@@ -1746,6 +1746,7 @@ procedure TTestRecordTypeParser.TestTwoFieldPrivateNoDelphi;
 Var
   EC : TClass;
 begin
+  EC:=nil;
   try
     TestFields(['private','x : integer'],'',False);
     Fail('Need po_Delphi for visibility specifier');
@@ -1761,16 +1762,22 @@ end;
 procedure TTestRecordTypeParser.TestTwoFieldProtected;
 Var
   B : Boolean;
+  EName: String;
 begin
+  B:=false;
+  EName:='';
   try
     TestFields(['protected','x : integer'],'',False);
     Fail('Protected not allowed as record visibility specifier')
   except
     on E : Exception do
+      begin
+      EName:=E.ClassName;
       B:=E is EParserError;
+      end;
   end;
   If not B then
-    Fail('Wrong exception class.');
+    Fail('Wrong exception class "'+EName+'".');
 end;
 
 procedure TTestRecordTypeParser.TestTwoFieldPrivate;