mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 09:26:09 +02:00
* More extensive examples taken from RTL
git-svn-id: trunk@19663 -
This commit is contained in:
michael
parent
d078996f69
commit
c9cd1079d4
@ -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,';');
|
||||
|
||||
@ -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;
|
||||
|
||||
procedure Expression;
|
||||
function addone : integer;
|
||||
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;
|
||||
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;
|
||||
(Co as TEdit).Text:= 'Some text';
|
||||
Co:= O as TComponent;
|
||||
|
||||
if A is TComponent then ;
|
||||
If A is B then ;
|
||||
if co is TComponent 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);
|
||||
|
||||
@ -629,8 +875,6 @@ Implementation
|
||||
else
|
||||
Filename:= s;
|
||||
|
||||
Self.Write(EscapeText(AText));
|
||||
TObject.Create(Self);
|
||||
end;
|
||||
|
||||
constructor TPasPackage.Create(const AName: String; AParent: TPasElement);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user