* More extensive examples taken from RTL

git-svn-id: trunk@19663 -

packages/fcl-passrc/examples/test_parser.pp

@@ -107,7 +107,7 @@
 
     TPasPackage = class(TPasElement)
       |
-    Modules: TList;
+    Modules: TFPList;
 
     TPasModule = class(TPasElement)
       |-InterfaceSection: TInterfaceSection;
@@ -115,27 +115,27 @@
       |
       |-ImplementationSection: TImplementationSection;
       |  |-Declarations -> full declaration, unit and program
-      |     |-Functions: TList;
+      |     |-Functions: TFPList;
       |        |-TPasFunction = class(TPasProcedureBase)
       |           |-Body: TProcedureBody;
       |              |-Declarations -> declaration and sub function
       |              |-Body: TPasImplBlock; -> procedure block
       |
       |-InitializationSection: TInitializationSection;
-      |  |-TPasImplBlock.Elements: TList; -> main block
+      |  |-TPasImplBlock.Elements: TFPList; -> main block
       |
       |-FinalizationSection: TFinalizationSection;
-         |-TPasImplBlock.Elements: TList; -> unit only
+         |-TPasImplBlock.Elements: TFPList; -> unit only
 
     Declarations = class(TPasElement)
-      |-Declarations: TList; -> the following are all in here
-      |-ResStrings: TList;
-      |-Types: TList;
-      |-Consts: TList;
-      |-Classes: TList;
-      |-Functions: TList;
-      |-Variables: TList;
-      |-Properties: TList;
+      |-Declarations: TFPList; -> the following are all in here
+      |-ResStrings: TFPList;
+      |-Types: TFPList;
+      |-Consts: TFPList;
+      |-Classes: TFPList;
+      |-Functions: TFPList;
+      |-Variables: TFPList;
+      |-Properties: TFPList;
     }
 
 
@@ -859,7 +859,7 @@ procedure GetTPasVar(lpv:TPasVariable; lindent:integer; NoLF:boolean);//BUG stri
   
 //write out a list of variables only
 //more compact than the output of seperate calls of GetTPasVar
-procedure GetPasVariables(vl:TList; lindent:integer; NoLF,NoSEM:boolean);
+procedure GetPasVariables(vl:TFPList; lindent:integer; NoLF,NoSEM:boolean);
    var v,i,j:integer;
        s,s1:string;
        prct:TPasRecordType;
@@ -1021,6 +1021,96 @@ procedure GetPasVariables(vl:TList; lindent:integer; NoLF,NoSEM:boolean);
     if not NoLF then writeln;
   end;  
   
+function GetTPasArgumentAccess(acc:TArgumentAccess):String;
+
+begin
+  Result:='';
+  case acc of
+    //argDefault:Result:='default'; //normal proccall is default
+    argConst:Result:='const';
+    argVar:Result:='var';
+    argOut:Result:='out';
+  end;
+end;
+
+procedure GetTPasProcedureType(lppt:TPasProcedureType; indent:integer);
+
+Var
+  l : integer;
+  lpa:TPasArgument;
+  samevar:array of integer;//same index same type
+  aktaa:TArgumentAccess;
+  svi:integer;
+  same:boolean;
+  aktname,tmpname:String;
+
+begin
+  if assigned(lppt.Args) and (lppt.Args.Count > 0) then
+    begin
+    write('(');
+    if lppt.Args.Count > 0 then
+     begin
+      //produce more compact output than the commented block below
+      //>find same declaration
+      //look ahead what is the same
+      SetLength(samevar,lppt.Args.Count);
+      svi:=0;
+      aktname:='';
+      for l:=0 to lppt.Args.Count-1 do
+       begin
+        same:=true;
+        tmpname:='';
+        lpa:=TPasArgument(lppt.Args.Items[l]);
+        if assigned(lpa.ArgType) then
+         begin
+          if lpa.ArgType is TPasArrayType then
+           begin
+             if assigned(TPasArrayType(lpa.ArgType).ElType) then tmpname:=TPasArrayType(lpa.ArgType).ElType.Name;
+           end
+            else tmpname:=TPasType(lpa.ArgType).Name;
+         end;
+        if l=0 then begin aktaa:=lpa.Access; aktname:=tmpname; end;
+        if lpa.Access <> aktaa then begin same:=false; aktaa:=lpa.Access; end;//access type
+        if (tmpname = '')or(tmpname <> aktname) then begin same:=false; aktname:=tmpname; end;//type name
+        if lpa.Value <> '' then same:=false;//var=value
+        if not same then inc(svi);
+        samevar[l]:=svi;
+       end;
+     //find same declaration<
+     svi:=-1;
+     same:=false;
+     for l:=0 to lppt.Args.Count-1 do
+      begin
+       lpa:=TPasArgument(lppt.Args.Items[l]);
+       if svi <> samevar[l] then
+        begin
+         svi:=samevar[l];
+         if lpa.Access <> argDefault then write(GetTPasArgumentAccess(lpa.Access),' ');
+         write(lpa.Name);//variblenname
+        end
+          else write(lpa.Name);
+       if (l < lppt.Args.Count-1)and(samevar[l+1]=svi) then write(',')
+        else
+         begin
+          if assigned(lpa.ArgType) then
+           begin
+            write(': ');
+            if lpa.ArgType is TPasArrayType then
+             GetTPasArrayType(TPasArrayType(lpa.ArgType))
+              else write(TPasType(lpa.ArgType).Name);
+           end;
+          if lpa.Value <> '' then write('=',lpa.Value);
+          if l< lppt.Args.Count-1 then write('; ');
+        end;
+      end;
+    write(')');
+    end;
+    end;
+  if (lppt is TPasFunctionType) then
+      write(': ',TPasFunctionType(lppt).ResultEl.ResultType.Name);
+  if lppt.IsOfObject then
+    write(' of Object');
+end;
 
 procedure GetTypes(pe:TPasElement; lindent:integer);
   var i,j,k:integer;
@@ -1110,7 +1200,12 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
    end
   else if pe is TPasProcedureType then
    begin
-    writeln('procedure');
+   if pe is TPasFunctionType then
+     Write('function ')
+   else
+     Write('procedure ');
+   GetTPasProcedureType(TPasProcedureType(pe), lindent);
+   Writeln(';');
    end
   else if pe is TPasPointerType then
    begin
@@ -1166,27 +1261,29 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
     writeln('set of ',pst.EnumType.Name,';');
    end
   else if pe is TPasClassOfType then writeln('Class of ',TPasClassOfType(pe).DestType.Name,';')
+  else if pe is tPasAliasType then
+    begin
+    pe:=tPasAliasType(PE).DestType;
+    write(PE.name);
+    if pe is tPasStringType then
+      begin
+      if (TPasStringType(PE).LengthExpr<>'') then
+        Write('[',TPasStringType(PE).LengthExpr,']');
+      end;
+    Writeln(';');
+    end
+  else if pe is tPasUnresolvedTypeRef then writeln(TPasUnresolvedTypeRef(PE).name,';')
   else
    begin
     
     writeln('{ Unknown TYPE(s): ');
-    writeln(s,pe.Name);
+    writeln(s,pe.Name,' ',pe.classname);
     writeln('}');
     writeln;
    end;
  end;
 
 
- function GetTPasArgumentAccess(acc:TArgumentAccess):String;
-  begin
-   Result:='';
-   case acc of
-     //argDefault:Result:='default'; //normal proccall is default
-     argConst:Result:='const';
-     argVar:Result:='var';
-     argOut:Result:='out';
-   end;
-  end;
 
  procedure GetTCallingConvention(cc:TCallingConvention);  //TODO: test it
   begin
@@ -1213,14 +1310,8 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
   procedure GetTPasProcedure(lpp:TPasProcedure; indent:integer);
    var l:integer;
        lppt:TPasProcedureType;
-       lpa:TPasArgument;
        s:String;
        
-       same:boolean;
-       samevar:array of integer;//same index same type
-       aktaa:TArgumentAccess;
-       aktname,tmpname:String;
-       svi:integer;
 
   begin
    if not Assigned(lpp) then exit;
@@ -1237,93 +1328,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
    if assigned(lpp.ProcType) then
     begin
      lppt:=lpp.ProcType;
-     if assigned(lppt.Args) and (lppt.Args.Count > 0) then
-      begin
-       write('(');
-       if lppt.Args.Count > 0 then 
-        begin
-         //produce more compact output than the commented block below
-         //>find same declaration
-         //look ahead what is the same
-         SetLength(samevar,lppt.Args.Count);
-         svi:=0;
-         aktname:='';
-         for l:=0 to lppt.Args.Count-1 do
-          begin
-           same:=true;
-           tmpname:='';
-           lpa:=TPasArgument(lppt.Args.Items[l]);
-           if assigned(lpa.ArgType) then
-            begin
-             if lpa.ArgType is TPasArrayType then
-              begin
-                if assigned(TPasArrayType(lpa.ArgType).ElType) then tmpname:=TPasArrayType(lpa.ArgType).ElType.Name;
-              end
-               else tmpname:=TPasType(lpa.ArgType).Name;
-            end;
-           if l=0 then begin aktaa:=lpa.Access; aktname:=tmpname; end;   
-           if lpa.Access <> aktaa then begin same:=false; aktaa:=lpa.Access; end;//access type 
-           if (tmpname = '')or(tmpname <> aktname) then begin same:=false; aktname:=tmpname; end;//type name
-           if lpa.Value <> '' then same:=false;//var=value
-           if not same then inc(svi); 
-           samevar[l]:=svi;
-          end; 
-        //find same declaration<  
-        svi:=-1;
-        same:=false;
-        for l:=0 to lppt.Args.Count-1 do
-         begin
-          lpa:=TPasArgument(lppt.Args.Items[l]);
-          if svi <> samevar[l] then
-           begin
-            svi:=samevar[l];
-            if lpa.Access <> argDefault then write(GetTPasArgumentAccess(lpa.Access),' '); 
-            write(lpa.Name);//variblenname
-           end
-             else write(lpa.Name); 
-          if (l < lppt.Args.Count-1)and(samevar[l+1]=svi) then write(',')
-           else
-            begin
-             if assigned(lpa.ArgType) then
-              begin
-               write(': ');
-               if lpa.ArgType is TPasArrayType then
-                GetTPasArrayType(TPasArrayType(lpa.ArgType))
-                 else write(TPasType(lpa.ArgType).Name);
-              end;
-             if lpa.Value <> '' then write('=',lpa.Value);
-             if l< lppt.Args.Count-1 then write('; ');
-           end;    
-         end; 
-       {//simple version duplicates declarations of same type
-        for l:=0 to lppt.Args.Count-1 do
-        begin
-         lpa:=TPasArgument(lppt.Args.Items[l]);
-          if lpa.Access <> argDefault then write(GetTPasArgumentAccess(lpa.Access),' '); 
-         write(lpa.Name);//variblenname
-         if assigned(lpa.ArgType) then
-          begin
-           //if TPasType(lpa.ArgType).ElementTypeName <>'unresolved type reference' then
-           //,TPasType(lpa.ArgType).Name,' ');
-           //,TPasType(lpa.ArgType).FullName,TPasType(lpa.ArgType).ElementTypeName)
-           // PParser 2099: ArgType := nil; if IsUntyped then => Arg.ArgType := ArgType;
-           //     else write(':? ');
-           write(': ');
-           if lpa.ArgType is TPasArrayType then
-            begin
-             GetTPasArrayType(TPasArrayType(lpa.ArgType));
-            end
-             else  write(TPasType(lpa.ArgType).Name);
-          end;
-         if lpa.Value <> '' then write('=',lpa.Value);
-         if l< lppt.Args.Count-1 then write('; ');
-        end;}
-        end;
-       write(')');
-      end;
-     if lppt.IsOfObject then write(' of Object'); 
-     if (TPasElement(lpp) is TPasFunction)or(TPasElement(lpp) is TPasClassFunction) then 
-         write(': ',TPasFunctionType(lpp.ProcType).ResultEl.ResultType.Name);
+     GetTPasProcedureType(lppt,Indent);
     end;
    //writeln(';');
    WriteFmt(false,'',true);
@@ -1425,7 +1430,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
        lpp:TPasProperty;
        lpa:TPasArgument;
        vis:TPasMemberVisibility;
-       vars:TList;
+       vars:TFPList;
        IsVar:boolean;
 
   procedure PrintVars;
@@ -1485,17 +1490,17 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
        writeln(';');
        exit;
       end;  
-    //Members: TList;
+    //Members: TFPList;
     //InterfaceGUID: String;
-    //ClassVars: TList; //is this always empty ?
+    //ClassVars: TFPList; //is this always empty ?
     //Modifiers: TStringList;
-    //Interfaces: TList;
+    //Interfaces: TFPList;
       s1:=GetIndent(indent+1);
       s2:=GetIndent(indent+2);
       if pc.Members.Count > 0 then
        begin
         writeln;
-        vars:=TList.Create;
+        vars:=TFPList.Create;
         IsVar:=false;
         for j:=0 to pc.Members.Count-1 do
          begin
@@ -1606,7 +1611,7 @@ procedure GetDecls(Decl:TPasDeclarations; indent:integer);
      ps:TPasSection;
      s:string;
      x:(None,ResStrings,Types,Consts,Classes,Functions,Variables,Properties);
-     l:TList;
+     l:TFPList;
 
   procedure PrintVars;
    begin
@@ -1618,7 +1623,7 @@ begin
  x:=None;
  if assigned(Decl)then
   begin
-   l:=TList.Create;
+   l:=TFPList.Create;
    pe:=TPasElement(Decl);
    if pe is TPasSection then
     begin
@@ -1914,7 +1919,6 @@ begin
           raise;
        end;
     end;
-
    if M is TPasProgram then
     begin
      writeln('Program ',M.Name,';');

packages/fcl-passrc/examples/testunit1.pp

@@ -12,6 +12,10 @@ interface
  uses 
   SysUtils,Classes;
 
+(*
+resourcestring
+ SParserErrorAtToken = 'parser error at token';
+ 
  const
   AnIntegerConst=1;
   AStringConst='Hello, World!';
@@ -22,13 +26,34 @@ interface
   ARecordConst: TMethod=(Code:nil;Data:nil);
   ASetConst=[true,false];
   ADeprecatedConst=1 deprecated;
+*)
    
  Type
+  TLineEndStr = string [3];
+
+  TDeprecatedType = Integer deprecated;
+  TDeprecatedRecord = Record
+    x,Y : Integer; 
+  end deprecated;
+  TDeprecatedFieldsRecord = Record
+    x,Y : Integer deprecated; 
+  end;
+  TDeprecatedFieldsRecord2 = Record
+    x,Y : Integer deprecated
+  end;
   TAnEnumType=(one,two,three);
   TASetType=set of TAnEnumType;
+  TIntegerSet = Set of 0..SizeOf(Integer)*8-1;
   TAnArrayType=Array[1..10] of Integer;
   TASubRangeType=one..two;
   TABooleanArrayType=Array[Boolean] of Integer;  
+  TDay = (monday,tuesday,wednesday,thursday,friday,saturday,sunday);
+  TShortDay = (mon,tue,wed,thu,fri,sat,sun);
+  TShortDays = set of TShortDay;
+  TDays = set of TDay;
+  TMyInteger = Integer;
+  ADouble = type double;
+  arangetypealias = type 0..$FF;
   TARecordType=record
                    X,Y: Integer;
                    Z: String;
@@ -54,9 +79,36 @@ interface
                  3 : (Z : Longint);  
                  );  
           end;                           
+
+TYPE
+   PPoint = ^TPoint;
+   TPoint = OBJECT
+      X, Y: Sw_Integer;
+   END;
+
+   PRect = ^TRect;
+   TRect = OBJECT
+      A, B: TPoint;                                { Corner points }
+      FUNCTION Empty: Boolean;
+      FUNCTION Equals (R: TRect): Boolean;
+      FUNCTION Contains (P: TPoint): Boolean;
+      PROCEDURE Copy (R: TRect);
+      PROCEDURE Union (R: TRect);
+      PROCEDURE Intersect (R: TRect);
+      PROCEDURE Move (ADX, ADY: Sw_Integer);
+      PROCEDURE Grow (ADX, ADY: Sw_Integer);
+      PROCEDURE Assign (XA, YA, XB, YB: Sw_Integer);
+   END;
+               
+
+  TNotifyEvent = Procedure (Sender : TObject) of object;
+  TNotifyEvent2 = Function (Sender : TObject) : Integer of object;
+ 
                           
 //  TADeprecatedType = Integer deprecated;
-
+  TMyChildClass = Class;
+  MyInterface = Interface;
+  
   { TMyParentClass }
 
   TMyParentClass=Class(TComponent)
@@ -99,18 +151,47 @@ interface
   Published
     Property AProtectedProp;
   end;
-  
- TPasFunctionType=Class(TPasProcedureType)
+  TC = TMyChildClass;
+
+  TPasFunctionType=Class(TObject)
   public
     destructor Destroy; override;
-    Class Function TypeName: string; override;
-    Function ElementTypeName: string; override;
-    Function GetDeclaration(Full: boolean): string; override;
+    Class Function TypeName: string;
+    Function ElementTypeName: string; 
+    Function GetDeclaration(Full: boolean): string; 
+    Procedure Something;  strict
+  Private  
+    Procedure SomethingElse;
   public
-    ResultEl: TPasResultElement;
+    ResultEl: TObject;
   end; 
-                        
- var
+
+  TPropModifiers = Class(TObject)
+  Private
+    FB : Integer;
+    Function IsStored : Boolean;
+    Function GetI(AI : Integer) : Integer;
+    Procedure SetI(AI : Integer; AVal : Integer);
+  Published
+    Property A : Integer Read FB Write FB Stored False;
+    Property B : Integer Read FB Write FB Stored True;
+    Property C : Integer Read FB Write FB Stored IsStored;
+    Property D : Integer Read FB Write FB Default 1;
+    Property E : Integer Read FB Write FB Stored True Default 1;
+  Public
+    Property Ints[AI : Integer] : Integer Read GetI Write SetI; default;
+  end;
+  
+  TPropModifiers2 = class(TPropModifiers)
+  Public
+    Property Ints[AI : Integer] : Integer Read GetI Write SetI; default; deprecated;
+  end;                          
+  
+  TEdit = Class(TObject)
+    Text : String;
+  end;
+  
+var
   ASimpleVar: Integer;  
   ATypedVar: TMethod;
   ARecordVar: Record
@@ -122,8 +203,16 @@ interface
   
   ADeprecatedVar: Integer deprecated;
   ACVarVar: Integer ; cvar;
-  AnExternalVar: Integer ;external name 'avar';
-  AnExternalLibVar: Integer ;external 'library' name 'avar';
+  AnExternalVar1: Integer; external;
+  AnExternalVar2: Integer; external name 'avar';
+  AnExternalLibVar: Integer; external 'library' name 'avar';
+  APublicVar : String; public;
+  APublicVar2 : String; public name 'ANAME';
+  APublicVar3 : String; export;
+  APublicVar4 : String; export name 'nono';
+  APublicVar5 : String; cvar; external;
+  APublicVar6 : String; external name 'me';
+  APublicVar7 : String deprecated; external name 'me';
       
  Procedure SimpleProc;
  Procedure OverloadedProc(A: Integer);
@@ -146,25 +235,31 @@ interface
  Procedure externalproc; external;
  Procedure externalnameProc; external name 'aname';
  Procedure externallibnameProc; external 'alibrary' name 'aname';
-
+ Function  hi(q : QWord) : DWord;   [INTERNPROC: fpc_in_hi_qword];
+(*
+ 
 Type
  generic TFPGListEnumerator<T> = class(TObject)
  protected
-    FList: TFPSList;
+    FList: TFPList;
     FPosition: Integer;
     function GetCurrent: T;
  end;                 
- TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>; 
+ TFPGListEnumeratorSpec = specialize TFPGListEnumerator<TPasFunctionType>; 
+*)
  
 Implementation
 
 
  Procedure SimpleProc;
 
- procedure  SubProc;
+  procedure  SubProc;
+  Var S : String;
   begin
    s:= s+'a';
   end;
+ Var
+   a,B,c,i : integer;
 
  begin
   a:= 1;
@@ -174,6 +269,8 @@ Implementation
  end;
 
  Procedure OverloadedProc(A: Integer);
+ Var
+   i : integer;
  begin
   if i=1 then ;
  end;
@@ -237,7 +334,11 @@ Implementation
  end;
 
  procedure TMyChildClass.AnAbstractProc;
+ 
  procedure  SubCProc;
+ 
+   Var sc : string;
+   
   begin
    sc:= sc+'ac';
   end;
@@ -308,12 +409,142 @@ Implementation
  procedure TMyParentClass.SomePublishedMethod;
  begin
  end;
- 
+
+
  Class Function TPasFunctionType.TypeName: String;
  begin
   Result:= 'Function';
  end;
 
+Type
+  TI = Class(TComponent)
+  Public
+    FP : Integer;
+    Procedure SetP1(A : Integer); virtual;
+    Procedure M1;virtual;
+    Function F1  : Integer; virtual;
+    procedure test; virtual;
+    property P : Integer Read FP Write SetP1;
+  end;
+  
+  Procedure TI.M1;
+  begin
+  end;
+  Procedure TI.Test;
+  begin
+  end;
+  Function TI.F1 : Integer; 
+  begin
+  Result:=0;
+  end;
+  Procedure TI.SetP1(A : Integer);
+  begin
+    FP:=A;
+  end;
+  
+TYpe
+  TI2 = Class(TI)
+  procedure write(s : string);
+  Procedure SetP1(A : Integer); override;
+  Procedure M1;override;
+  Procedure Test;override;
+  Function F1 : integer; override;
+  procedure donothing;
+  property P : Integer Read F1 Write SetP1;
+  end;
+  Procedure TI2.M1;
+  begin
+    Inherited;
+  end;
+  Procedure TI2.Write(s : string);
+  begin
+    writeln(s);
+  end;
+  Function TI2.F1 :Integer; 
+  begin
+     Result:=0;
+  end;
+  Procedure TI2.Test;
+  begin
+  if true then
+    Inherited Test
+  else
+    DoNothing;
+    Inherited test;
+   if true then
+     Inherited
+   else
+     DoNothing;
+  end;
+  Procedure TI2.DoNothing;
+    function escapetext(s : string) : string;
+    begin
+    end;
+  var
+  Atext : string;
+  begin
+    Self.Write(EscapeText(AText)); 
+    TComponent.Create(Self);
+  end;
+  Procedure TI2.SetP1(A : Integer);
+  begin
+    FP:=A;
+    Inherited P:= 3;
+    Inherited SetP1(3);
+    Inherited P:= Ord(A);
+  end;
+
+
+ procedure usage;
+ begin
+ end;
+ Procedure DoSomething;
+ begin
+ end;
+ Procedure DoSomethingElse;
+ begin
+ end;
+ procedure stat1;
+ begin
+ end;
+ procedure stat2;
+ begin
+ end;
+ procedure stat3;
+ begin
+ end;
+ procedure stat4;
+ begin
+ end;
+ procedure stat5;
+ begin
+ end;
+ procedure stat6;
+ begin
+ end;
+ procedure stat7;
+ begin
+ end;
+  procedure stat8;
+ begin
+ end;
+ procedure stat9;
+ begin
+ end;
+ procedure doit;
+ begin
+ end;
+ procedure statement;
+ begin
+ end;
+ procedure work;
+ begin
+ end;
+ procedure kissdwarf(i : integer);
+ 
+ begin
+   writeln('kiss dwarf',i);
+ end;
  procedure Statements;
  const
   cint=1;
@@ -348,14 +579,32 @@ Implementation
   AR=record
       X,Y: LongInt;
      end;
+  TScanner = record
+   currow,curcolumn : integer;
+   curfilename : string;
+  end;  
+
   //PAR = Record;
  var
+  msg,curtokenname : string;
   TheCustomer: Passenger;
   L: ^LongInt;
   P: PPChar;
   S,T: Ar;
-      
+  M, X,Y : Double;
+  Done : Boolean;
+  Weather,Good: Boolean;  
+  c : char;
+  j,dwarfs,i,Number,Block : integer;
+  exp1,exp2,exp3,exp4,exp5,exp6,exp7,exp8,exp9 : boolean;
+  o : Tobject;
+  day,today : tday;
+  A,B,D : Passenger;
+  E : Exception;
+  scanner : tscanner;
+    
  begin
+  O:=Nil;
   X:= X+Y;
   //EparserError on C++ style
   //X+=Y;      { Same as X := X+Y, needs -Sc command line switch}
@@ -376,7 +625,7 @@ Implementation
   //Goto jumpto;
 
   Case i of
-    3: DoSomething;
+    6: DoSomething;
     1..5: DoSomethingElse;
   end;
 
@@ -434,19 +683,19 @@ Implementation
   else
     stat2;
 
- if i is integer then
+ if o is TObject then
   begin
-    write('integer');
+    write('object');
   end
   else 
-    if i is real then 
+    if o is TMyParentClass then 
   begin
     write('real');
   end
   else 
     write('0'); 
 
-  if Today in[Monday..Friday] then
+  if Today in [Monday..Friday] then
     WriteLn('Must work harder')
   else
     WriteLn('Take a day off.');
@@ -480,21 +729,21 @@ Implementation
      I:= I+2;
     end;
     X:= X/2;
-    while x>=10e-3 do 
-      dec(x);
+    while i>=10e-3 do 
+      dec(i);
 
-    while x>0 do 
-    while y>0 do 
+    while i>0 do 
+    while j>0 do 
       begin
-	dec(x);
-	dec(y);
+	dec(i);
+	dec(j);
       end;
 
-    while x>0 do
-    if x>2 then 
-     dec(x)
+    while i>0 do
+    if i>2 then 
+     dec(i)
     else 
-     dec(x,2);
+     dec(i,2);
 
       X:= 2+3;
 
@@ -507,12 +756,11 @@ Implementation
        Flight:= 'PS901';
       end;
 
-  With A,B,C,D do
+  With A,B,D do
    Statement;
 
     With A do
      With B do
-      With C do
        With D do 
         Statement;
 
@@ -529,60 +777,77 @@ Implementation
 
     try
 	try
-	  M:= ParseSource(E,cmdl,'linux','i386');
+	  M:= Y;
 	except
 	  on excep: EParserError do
 	    begin
-	      writeln(excep.message,' line:',excep.row,' column:',excep.column,' file:',excep.filename);
+	      writeln(excep.message,' : ',excep.classname);
 	      raise ;
 	  end;
 	end;
-	Decls:= M.InterfaceSection.Declarations;
-	for I:= 0 to Decls.Count-1 do
-	  Writeln('Interface item ',I,': ');
-
 	FreeAndNil(M);
     finally
 	FreeAndNil(E)
    end;
    
-   raise EParserError.Create(Format(SParserErrorAtToken, [Msg, CurTokenName]) {$ifdef addlocation}+' ('+inttostr(scanner.currow)+' '+inttostr(scanner.curcolumn)+')'{$endif},Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
+   raise EParserError.Create(Format(SParserErrorAtToken, [Msg, CurTokenName]) {$ifdef addlocation}+' ('+inttostr(scanner.currow)+' '+inttostr(scanner.curcolumn)+')'{$endif});
     
     // try else
  end;
 
+ function addone : integer;
+ begin
+ end;
+  procedure myproc;
+  begin
+  end;
  procedure Expression;
+
+  Var
+    A,b,c,d,e,f,i,j : Integer;
+    x : double;
+    u : Boolean;
+    fu : function : integer;
+    ad : boolean;
+    z : tdays;
+    today,tomorrow : tday;
+    bs : set of byte;
+    cs : set of char;
+    cc : char;  
+    W : TShortDays;
+    buffer : array[1..10] of byte;
+    P : Pointer;
+    SErrMultipleSourceFiles,FileName,Dirname,S : string;
+    o,co : tobject;
+    
  begin
-  A:= a+b *c /(-e+f)*3 div 2 + 4 mod 5 - 2 shl 3 + 3 shr 1 ;
+  x:= a+b *c /(-e+f)*(3 div 2) + 4 mod 5 - 2 shl 3 + 3 shr 1 ;
   b:= (a and not b) or c xor d;
-  u:= i<=2 or a<>b or j>=3;
-  u:= i=1 or a>b or b<a or i<>2;
+  u:= (i<=2) or (a<>b) or (j>=3);
+  u:= (i=1) or (a>b) or (b<a) or (i<>2);
   u:= i in [1..2];
 
- If F=@AddOne Then  
+ If Fu=@AddOne Then  
   WriteLn('Functions are equal');
 
- If F()=Addone then  
+ If Fu()=Addone then  
   WriteLn('Functions return same values ');
 
  z:= [today,tomorrow];
  z:= [Monday..Friday,Sunday];
- z:= [2,3*2,6*2,9*2];
- z:= ['A'..'Z','a'..'z','0'..'9'];
+ bs:= [2,3*2,6*2,9*2];
+ cs:= ['A'..'Z','a'..'z','0'..'9'];
 
- x:= Byte('A');
- x:= Char(48);
- x:= boolean(1);
- x:= longint(@Buffer);
- x:= Integer('A');
- x:= Char(4875);
- x:= Word(@Buffer);
+ i:= Byte('A');
+ cc:= Char(48);
+ ad:= boolean(1);
+ i:= longint(@Buffer);
+ i:= Integer('A');
+ cc:= Char(225);
+ i:= Word(@Buffer);
 
  B:= Byte(C);
- Char(B):= C;
 
- TWordRec(W).L:= $FF;
- TWordRec(W).H:= 0;
  S:= TObject(P).ClassName;
 
  P:= @MyProc; //warum @ ? fix pparser 769 ?
@@ -593,31 +858,12 @@ Implementation
  W:= [mon,tue,wed]-[wed];     // equals [mon,tue]
  W:= [mon,tue,wed]*[wed,thu,fri]; // equals [wed] warum * ?
 
- (C as TEdit).Text:= 'Some text';
- C:= O as TComponent;
-
- if A is TComponent then ;
- If A is B then ;
-
- Inherited ;
- Inherited Test;
-
-  if true then
-    Inherited
-  else
-    DoNothing;
+ (Co as TEdit).Text:= 'Some text';
+ Co:= O as TComponent;
 
-  if true then
-    Inherited Test
-  else
-    DoNothing;
+ if co is TComponent then ;
+ If co is TC then ;
 
-   Inherited P:= 3;  
-   Inherited SetP1(3); 
-   Result:= Char(P and $FF);  
-   Result:= Char((Inherited P) and $FF);  
-   Inherited P:= Ord(AValue);
-   Result:= Inherited InterPretOption(Cmd,Arg);
 
   raise Exception.Create(SErrMultipleSourceFiles);
 
@@ -629,8 +875,6 @@ Implementation
 	else
 	  Filename:= s;
 
-  Self.Write(EscapeText(AText)); 
-  TObject.Create(Self);
  end;
 
  constructor TPasPackage.Create(const AName: String; AParent: TPasElement);