paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-22 15:29:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* More extensive examples taken from RTL

Browse Source 
git-svn-id: trunk@19663 -
This commit is contained in:
michael 2011-11-20 22:48:29 +00:00
parent d078996f69
commit c9cd1079d4
2 changed files with 458 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

256
packages/fcl-passrc/examples/test_parser.pp
View File

@ -107,7 +107,7 @@
TPasPackage = class(TPasElement) TPasPackage = class(TPasElement)
| |
Modules: TList; Modules: TFPList;
TPasModule = class(TPasElement) TPasModule = class(TPasElement)
|-InterfaceSection: TInterfaceSection; |-InterfaceSection: TInterfaceSection;
@ -115,27 +115,27 @@
| |
|-ImplementationSection: TImplementationSection; |-ImplementationSection: TImplementationSection;
| |-Declarations -> full declaration, unit and program | |-Declarations -> full declaration, unit and program
| |-Functions: TList; | |-Functions: TFPList;
| |-TPasFunction = class(TPasProcedureBase) | |-TPasFunction = class(TPasProcedureBase)
| |-Body: TProcedureBody; | |-Body: TProcedureBody;
| |-Declarations -> declaration and sub function | |-Declarations -> declaration and sub function
| |-Body: TPasImplBlock; -> procedure block | |-Body: TPasImplBlock; -> procedure block
| |
|-InitializationSection: TInitializationSection; |-InitializationSection: TInitializationSection;
| |-TPasImplBlock.Elements: TList; -> main block | |-TPasImplBlock.Elements: TFPList; -> main block
| |
|-FinalizationSection: TFinalizationSection; |-FinalizationSection: TFinalizationSection;
|-TPasImplBlock.Elements: TList; -> unit only |-TPasImplBlock.Elements: TFPList; -> unit only
Declarations = class(TPasElement) Declarations = class(TPasElement)
|-Declarations: TList; -> the following are all in here |-Declarations: TFPList; -> the following are all in here
|-ResStrings: TList; |-ResStrings: TFPList;
|-Types: TList; |-Types: TFPList;
|-Consts: TList; |-Consts: TFPList;
|-Classes: TList; |-Classes: TFPList;
|-Functions: TList; |-Functions: TFPList;
|-Variables: TList; |-Variables: TFPList;
|-Properties: TList; |-Properties: TFPList;
} }
@ -859,7 +859,7 @@ procedure GetTPasVar(lpv:TPasVariable; lindent:integer; NoLF:boolean);//BUG stri
//write out a list of variables only //write out a list of variables only
//more compact than the output of seperate calls of GetTPasVar //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; var v,i,j:integer;
s,s1:string; s,s1:string;
prct:TPasRecordType; prct:TPasRecordType;
@ -1021,6 +1021,96 @@ procedure GetPasVariables(vl:TList; lindent:integer; NoLF,NoSEM:boolean);
if not NoLF then writeln; if not NoLF then 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 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); procedure GetTypes(pe:TPasElement; lindent:integer);
var i,j,k:integer; var i,j,k:integer;
@ -1110,7 +1200,12 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
end end
else if pe is TPasProcedureType then else if pe is TPasProcedureType then
begin begin
writeln('procedure'); if pe is TPasFunctionType then
Write('function ')
else
Write('procedure ');
GetTPasProcedureType(TPasProcedureType(pe), lindent);
Writeln(';');
end end
else if pe is TPasPointerType then else if pe is TPasPointerType then
begin begin
@ -1166,27 +1261,29 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
writeln('set of ',pst.EnumType.Name,';'); writeln('set of ',pst.EnumType.Name,';');
end end
else if pe is TPasClassOfType then writeln('Class of ',TPasClassOfType(pe).DestType.Name,';') 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 else
begin begin
writeln('{ Unknown TYPE(s): '); writeln('{ Unknown TYPE(s): ');
writeln(s,pe.Name); writeln(s,pe.Name,' ',pe.classname);
writeln('}'); writeln('}');
writeln; writeln;
end; end;
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 procedure GetTCallingConvention(cc:TCallingConvention); //TODO: test it
begin begin
@ -1213,14 +1310,8 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
procedure GetTPasProcedure(lpp:TPasProcedure; indent:integer); procedure GetTPasProcedure(lpp:TPasProcedure; indent:integer);
var l:integer; var l:integer;
lppt:TPasProcedureType; lppt:TPasProcedureType;
lpa:TPasArgument;
s:String; s:String;
same:boolean;
samevar:array of integer;//same index same type
aktaa:TArgumentAccess;
aktname,tmpname:String;
svi:integer;
begin begin
if not Assigned(lpp) then exit; if not Assigned(lpp) then exit;
@ -1237,93 +1328,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
if assigned(lpp.ProcType) then if assigned(lpp.ProcType) then
begin begin
lppt:=lpp.ProcType; lppt:=lpp.ProcType;
if assigned(lppt.Args) and (lppt.Args.Count > 0) then GetTPasProcedureType(lppt,Indent);
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);
end; end;
//writeln(';'); //writeln(';');
WriteFmt(false,'',true); WriteFmt(false,'',true);
@ -1425,7 +1430,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
lpp:TPasProperty; lpp:TPasProperty;
lpa:TPasArgument; lpa:TPasArgument;
vis:TPasMemberVisibility; vis:TPasMemberVisibility;
vars:TList; vars:TFPList;
IsVar:boolean; IsVar:boolean;
procedure PrintVars; procedure PrintVars;
@ -1485,17 +1490,17 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
writeln(';'); writeln(';');
exit; exit;
end; end;
//Members: TList; //Members: TFPList;
//InterfaceGUID: String; //InterfaceGUID: String;
//ClassVars: TList; //is this always empty ? //ClassVars: TFPList; //is this always empty ?
//Modifiers: TStringList; //Modifiers: TStringList;
//Interfaces: TList; //Interfaces: TFPList;
s1:=GetIndent(indent+1); s1:=GetIndent(indent+1);
s2:=GetIndent(indent+2); s2:=GetIndent(indent+2);
if pc.Members.Count > 0 then if pc.Members.Count > 0 then
begin begin
writeln; writeln;
vars:=TList.Create; vars:=TFPList.Create;
IsVar:=false; IsVar:=false;
for j:=0 to pc.Members.Count-1 do for j:=0 to pc.Members.Count-1 do
begin begin
@ -1606,7 +1611,7 @@ procedure GetDecls(Decl:TPasDeclarations; indent:integer);
ps:TPasSection; ps:TPasSection;
s:string; s:string;
x:(None,ResStrings,Types,Consts,Classes,Functions,Variables,Properties); x:(None,ResStrings,Types,Consts,Classes,Functions,Variables,Properties);
l:TList; l:TFPList;
procedure PrintVars; procedure PrintVars;
begin begin
@ -1618,7 +1623,7 @@ begin
x:=None; x:=None;
if assigned(Decl)then if assigned(Decl)then
begin begin
l:=TList.Create; l:=TFPList.Create;
pe:=TPasElement(Decl); pe:=TPasElement(Decl);
if pe is TPasSection then if pe is TPasSection then
begin begin
@ -1914,7 +1919,6 @@ begin
raise; raise;
end; end;
end; end;
if M is TPasProgram then if M is TPasProgram then
begin begin
writeln('Program ',M.Name,';'); writeln('Program ',M.Name,';');

392
packages/fcl-passrc/examples/testunit1.pp
View File

@ -12,6 +12,10 @@ interface
uses uses
SysUtils,Classes; SysUtils,Classes;
(*
resourcestring
SParserErrorAtToken = 'parser error at token';
const const
AnIntegerConst=1; AnIntegerConst=1;
AStringConst='Hello, World!'; AStringConst='Hello, World!';
@ -22,13 +26,34 @@ interface
ARecordConst: TMethod=(Code:nil;Data:nil); ARecordConst: TMethod=(Code:nil;Data:nil);
ASetConst=[true,false]; ASetConst=[true,false];
ADeprecatedConst=1 deprecated; ADeprecatedConst=1 deprecated;
*)
Type 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); TAnEnumType=(one,two,three);
TASetType=set of TAnEnumType; TASetType=set of TAnEnumType;
TIntegerSet = Set of 0..SizeOf(Integer)*8-1;
TAnArrayType=Array[1..10] of Integer; TAnArrayType=Array[1..10] of Integer;
TASubRangeType=one..two; TASubRangeType=one..two;
TABooleanArrayType=Array[Boolean] of Integer; 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 TARecordType=record
X,Y: Integer; X,Y: Integer;
Z: String; Z: String;
@ -55,7 +80,34 @@ interface
); );
end; 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; // TADeprecatedType = Integer deprecated;
TMyChildClass = Class;
MyInterface = Interface;
{ TMyParentClass } { TMyParentClass }
@ -99,15 +151,44 @@ interface
Published Published
Property AProtectedProp; Property AProtectedProp;
end; end;
TC = TMyChildClass;
TPasFunctionType=Class(TPasProcedureType) TPasFunctionType=Class(TObject)
public public
destructor Destroy; override; destructor Destroy; override;
Class Function TypeName: string; override; Class Function TypeName: string;
Function ElementTypeName: string; override; Function ElementTypeName: string;
Function GetDeclaration(Full: boolean): string; override; Function GetDeclaration(Full: boolean): string;
Procedure Something; strict
Private
Procedure SomethingElse;
public public
ResultEl: TPasResultElement; ResultEl: TObject;
end;
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; end;
var var
@ -122,8 +203,16 @@ interface
ADeprecatedVar: Integer deprecated; ADeprecatedVar: Integer deprecated;
ACVarVar: Integer ; cvar; ACVarVar: Integer ; cvar;
AnExternalVar: Integer ;external name 'avar'; AnExternalVar1: Integer; external;
AnExternalVar2: Integer; external name 'avar';
AnExternalLibVar: Integer; external 'library' 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 SimpleProc;
Procedure OverloadedProc(A: Integer); Procedure OverloadedProc(A: Integer);
@ -146,15 +235,18 @@ interface
Procedure externalproc; external; Procedure externalproc; external;
Procedure externalnameProc; external name 'aname'; Procedure externalnameProc; external name 'aname';
Procedure externallibnameProc; external 'alibrary' name 'aname'; Procedure externallibnameProc; external 'alibrary' name 'aname';
Function hi(q : QWord) : DWord; [INTERNPROC: fpc_in_hi_qword];
(*
Type Type
generic TFPGListEnumerator<T> = class(TObject) generic TFPGListEnumerator<T> = class(TObject)
protected protected
FList: TFPSList; FList: TFPList;
FPosition: Integer; FPosition: Integer;
function GetCurrent: T; function GetCurrent: T;
end; end;
TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>; TFPGListEnumeratorSpec = specialize TFPGListEnumerator<TPasFunctionType>;
*)
Implementation Implementation
@ -162,9 +254,12 @@ Implementation
Procedure SimpleProc; Procedure SimpleProc;
procedure SubProc; procedure SubProc;
Var S : String;
begin begin
s:= s+'a'; s:= s+'a';
end; end;
Var
a,B,c,i : integer;
begin begin
a:= 1; a:= 1;
@ -174,6 +269,8 @@ Implementation
end; end;
Procedure OverloadedProc(A: Integer); Procedure OverloadedProc(A: Integer);
Var
i : integer;
begin begin
if i=1 then ; if i=1 then ;
end; end;
@ -237,7 +334,11 @@ Implementation
end; end;
procedure TMyChildClass.AnAbstractProc; procedure TMyChildClass.AnAbstractProc;
procedure SubCProc; procedure SubCProc;
Var sc : string;
begin begin
sc:= sc+'ac'; sc:= sc+'ac';
end; end;
@ -309,11 +410,141 @@ Implementation
begin begin
end; end;
Class Function TPasFunctionType.TypeName: String; Class Function TPasFunctionType.TypeName: String;
begin begin
Result:= 'Function'; Result:= 'Function';
end; 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; procedure Statements;
const const
cint=1; cint=1;
@ -348,14 +579,32 @@ Implementation
AR=record AR=record
X,Y: LongInt; X,Y: LongInt;
end; end;
TScanner = record
currow,curcolumn : integer;
curfilename : string;
end;
//PAR = Record; //PAR = Record;
var var
msg,curtokenname : string;
TheCustomer: Passenger; TheCustomer: Passenger;
L: ^LongInt; L: ^LongInt;
P: PPChar; P: PPChar;
S,T: Ar; 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 begin
O:=Nil;
X:= X+Y; X:= X+Y;
//EparserError on C++ style //EparserError on C++ style
//X+=Y; { Same as X := X+Y, needs -Sc command line switch} //X+=Y; { Same as X := X+Y, needs -Sc command line switch}
@ -376,7 +625,7 @@ Implementation
//Goto jumpto; //Goto jumpto;
Case i of Case i of
3: DoSomething; 6: DoSomething;
1..5: DoSomethingElse; 1..5: DoSomethingElse;
end; end;
@ -434,12 +683,12 @@ Implementation
else else
stat2; stat2;
if i is integer then if o is TObject then
begin begin
write('integer'); write('object');
end end
else else
if i is real then if o is TMyParentClass then
begin begin
write('real'); write('real');
end end
@ -480,21 +729,21 @@ Implementation
I:= I+2; I:= I+2;
end; end;
X:= X/2; X:= X/2;
while x>=10e-3 do while i>=10e-3 do
dec(x); dec(i);
while x>0 do while i>0 do
while y>0 do while j>0 do
begin begin
dec(x); dec(i);
dec(y); dec(j);
end; end;
while x>0 do while i>0 do
if x>2 then if i>2 then
dec(x) dec(i)
else else
dec(x,2); dec(i,2);
X:= 2+3; X:= 2+3;
@ -507,12 +756,11 @@ Implementation
Flight:= 'PS901'; Flight:= 'PS901';
end; end;
With A,B,C,D do With A,B,D do
Statement; Statement;
With A do With A do
With B do With B do
With C do
With D do With D do
Statement; Statement;
@ -529,60 +777,77 @@ Implementation
try try
try try
M:= ParseSource(E,cmdl,'linux','i386'); M:= Y;
except except
on excep: EParserError do on excep: EParserError do
begin begin
writeln(excep.message,' line:',excep.row,' column:',excep.column,' file:',excep.filename); writeln(excep.message,' : ',excep.classname);
raise ; raise ;
end; end;
end; end;
Decls:= M.InterfaceSection.Declarations;
for I:= 0 to Decls.Count-1 do
Writeln('Interface item ',I,': ');
FreeAndNil(M); FreeAndNil(M);
finally finally
FreeAndNil(E) FreeAndNil(E)
end; 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 // try else
end; end;
procedure Expression; function addone : integer;
begin begin
A:= a+b *c /(-e+f)*3 div 2 + 4 mod 5 - 2 shl 3 + 3 shr 1 ; 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
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; b:= (a and not b) or c xor d;
u:= i<=2 or a<>b or j>=3; u:= (i<=2) or (a<>b) or (j>=3);
u:= i=1 or a>b or b<a or i<>2; u:= (i=1) or (a>b) or (b<a) or (i<>2);
u:= i in [1..2]; u:= i in [1..2];
If F=@AddOne Then If Fu=@AddOne Then
WriteLn('Functions are equal'); WriteLn('Functions are equal');
If F()=Addone then If Fu()=Addone then
WriteLn('Functions return same values '); WriteLn('Functions return same values ');
z:= [today,tomorrow]; z:= [today,tomorrow];
z:= [Monday..Friday,Sunday]; z:= [Monday..Friday,Sunday];
z:= [2,3*2,6*2,9*2]; bs:= [2,3*2,6*2,9*2];
z:= ['A'..'Z','a'..'z','0'..'9']; cs:= ['A'..'Z','a'..'z','0'..'9'];
x:= Byte('A'); i:= Byte('A');
x:= Char(48); cc:= Char(48);
x:= boolean(1); ad:= boolean(1);
x:= longint(@Buffer); i:= longint(@Buffer);
x:= Integer('A'); i:= Integer('A');
x:= Char(4875); cc:= Char(225);
x:= Word(@Buffer); i:= Word(@Buffer);
B:= Byte(C); B:= Byte(C);
Char(B):= C;
TWordRec(W).L:= $FF;
TWordRec(W).H:= 0;
S:= TObject(P).ClassName; S:= TObject(P).ClassName;
P:= @MyProc; //warum @ ? fix pparser 769 ? P:= @MyProc; //warum @ ? fix pparser 769 ?
@ -593,31 +858,12 @@ Implementation
W:= [mon,tue,wed]-[wed]; // equals [mon,tue] W:= [mon,tue,wed]-[wed]; // equals [mon,tue]
W:= [mon,tue,wed]*[wed,thu,fri]; // equals [wed] warum * ? W:= [mon,tue,wed]*[wed,thu,fri]; // equals [wed] warum * ?
(C as TEdit).Text:= 'Some text'; (Co as TEdit).Text:= 'Some text';
C:= O as TComponent; Co:= O as TComponent;
if A is TComponent then ; if co is TComponent then ;
If A is B then ; If co is TC then ;
Inherited ;
Inherited Test;
if true then
Inherited
else
DoNothing;
if true then
Inherited Test
else
DoNothing;
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); raise Exception.Create(SErrMultipleSourceFiles);
@ -629,8 +875,6 @@ Implementation
else else
Filename:= s; Filename:= s;
Self.Write(EscapeText(AText));
TObject.Create(Self);
end; end;
constructor TPasPackage.Create(const AName: String; AParent: TPasElement); constructor TPasPackage.Create(const AName: String; AParent: TPasElement);