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

--- Merging r35428 into '.':

Browse Source 
U    packages/pastojs/tests/tcconverter.pp
U    packages/pastojs/tests/tcmodules.pas
U    packages/pastojs/src/fppas2js.pp
U    packages/fcl-js/src/jstree.pp
U    packages/fcl-passrc/src/pasresolver.pp
U    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/src/pastree.pp
U    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35428 into '.':
 U   .
--- Merging r35468 into '.':
U    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35468 into '.':
 G   .
--- Merging r35469 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35469 into '.':
 G   .
--- Merging r35470 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35470 into '.':
 G   .
--- Merging r35472 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
U    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35472 into '.':
 G   .
--- Merging r35487 into '.':
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35487 into '.':
 G   .
--- Merging r35488 into '.':
U    packages/fcl-passrc/tests/tcbaseparser.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35488 into '.':
 G   .
--- Merging r35489 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35489 into '.':
 G   .
--- Merging r35490 into '.':
G    packages/fcl-js/src/jstree.pp
--- Recording mergeinfo for merge of r35490 into '.':
 G   .
--- Merging r35491 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
G    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35491 into '.':
 G   .
--- Merging r35502 into '.':
U    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r35502 into '.':
 G   .
--- Merging r35503 into '.':
G    packages/fcl-passrc/src/pparser.pp
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
U    packages/fcl-passrc/src/passrcutil.pp
G    packages/fcl-passrc/src/pscanner.pp
U    packages/fcl-passrc/tests/tcexprparser.pas
G    packages/fcl-passrc/tests/tcresolver.pas
U    packages/fcl-passrc/tests/tcvarparser.pas
--- Recording mergeinfo for merge of r35503 into '.':
 G   .
--- Merging r35504 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35504 into '.':
 G   .
--- Merging r35505 into '.':
G    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35505 into '.':
 G   .
--- Merging r35512 into '.':
U    packages/fcl-web/src/base/httpdefs.pp
--- Recording mergeinfo for merge of r35512 into '.':
 G   .
--- Merging r35513 into '.':
G    packages/fcl-web/src/base/httpdefs.pp
--- Recording mergeinfo for merge of r35513 into '.':
 G   .
--- Merging r35514 into '.':
U    packages/fcl-web/src/base/custcgi.pp
--- Recording mergeinfo for merge of r35514 into '.':
 G   .
--- Merging r35515 into '.':
U    packages/fcl-web/src/base/httproute.pp
--- Recording mergeinfo for merge of r35515 into '.':
 G   .
--- Merging r35516 into '.':
U    packages/fcl-web/src/base/fphttpclient.pp
--- Recording mergeinfo for merge of r35516 into '.':
 G   .
--- Merging r35522 into '.':
U    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35522 into '.':
 G   .
--- Merging r35524 into '.':
G    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/tcprocfunc.pas
--- Recording mergeinfo for merge of r35524 into '.':
 G   .
--- Merging r35561 into '.':
U    packages/fcl-json/src/fpjsonrtti.pp
U    packages/fcl-json/tests/testjsonrtti.pp
--- Recording mergeinfo for merge of r35561 into '.':
 G   .
--- Merging r35562 into '.':
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/tcscanner.pas
--- Recording mergeinfo for merge of r35562 into '.':
 G   .

# revisions: 35428,35468,35469,35470,35472,35487,35488,35489,35490,35491,35502,35503,35504,35505,35512,35513,35514,35515,35516,35522,35524,35561,35562

git-svn-id: branches/fixes_3_0@35984 -
This commit is contained in:
marco 2017-04-27 17:42:06 +00:00
parent be53a5754e
commit b300edd432
24 changed files with 10474 additions and 2414 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
packages/fcl-js/src/jstree.pp
View File

@ -121,7 +121,7 @@ Type
TJSString = jsbase.TJSString; // beware of jstoken.tjsString
{ TJSFuncDef - e.g. 'function Name(Params)Body' }
{ TJSFuncDef - part of TJSFunctionDeclarationStatement, e.g. 'function Name(Params)Body' }
TJSFuncDef = Class(TJSObject)
private
@ -457,7 +457,7 @@ Type
TJSVariableDeclarationList = Class(TJSBinary); // A->first variable, B->next in list, chained.
{ TJSWithStatement }
{ TJSWithStatement - with(A)do B; }
TJSWithStatement = Class(TJSBinary); // A-> with expression, B->statement(s)

219
packages/fcl-js/src/jswriter.pp
View File

@ -20,7 +20,7 @@ unit jswriter;
interface
uses
{Classes, } SysUtils, jstoken, jsbase, jstree;
SysUtils, jstoken, jsbase, jstree;
Type
@ -31,7 +31,7 @@ Type
Function DoWrite(Const S : AnsiString) : Integer; virtual; abstract;
Function DoWrite(Const S : UnicodeString) : Integer; virtual; abstract;
Public
// All functions return the numberof bytes copied to output stream.
// All functions return the number of bytes copied to output stream.
Function Write(Const S : UnicodeString) : Integer;
Function Write(Const S : AnsiString) : Integer;
Function WriteLn(Const S : AnsiString) : Integer;
@ -58,6 +58,7 @@ Type
end;
{ TBufferWriter }
TBytes = Array of byte;
TBufferWriter = Class(TTextWriter)
private
@ -157,8 +158,7 @@ Type
Procedure WritePrimaryExpression(El: TJSPrimaryExpression);virtual;
Procedure WriteBinary(El: TJSBinary);virtual;
Public
Function EscapeString(const S: TJSString; Quote: TJSEscapeQuote = jseqDouble): String;
Function JSStringToStr(const S: TJSString): string;
Function EscapeString(const S: TJSString; Quote: TJSEscapeQuote = jseqDouble): TJSString;
Constructor Create(AWriter : TTextWriter);
Constructor Create(Const AFileName : String);
Destructor Destroy; override;
@ -172,12 +172,31 @@ Type
end;
EJSWriter = Class(Exception);
Function UTF16ToUTF8(const S: UnicodeString): string;
implementation
Resourcestring
SErrUnknownJSClass = 'Unknown javascript element class : %s';
SErrNilNode = 'Nil node in Javascript';
function HexDump(p: PChar; Count: integer): string;
var
i: Integer;
begin
Result:='';
for i:=0 to Count-1 do
Result:=Result+HexStr(ord(p[i]),2);
end;
function UTF16ToUTF8(const S: UnicodeString): string;
begin
Result:=UTF8Encode(S);
// prevent UTF8 codepage appear in the strings - we don't need codepage
// conversion magic
SetCodePage(RawByteString(Result), CP_ACP, False);
end;
{ TBufferWriter }
function TBufferWriter.GetBufferLength: Integer;
@ -332,13 +351,13 @@ end;
procedure TJSWriter.Write(const U: UnicodeString);
Var
S : UTF8String;
S : String;
begin
WriteIndent;
if UseUTF8 then
begin
S:=UTF8Encode(U);
S:=UTF16ToUTF8(U);
FLinePos:=FLinePos+Writer.Write(S);
end
else
@ -370,12 +389,12 @@ end;
procedure TJSWriter.WriteLn(const U: UnicodeString);
Var
S : UTF8String;
S : String;
begin
if UseUTF8 then
begin
S:=UTF8Encode(U);
S:=UTF16ToUTF8(U);
Writeln(S);
end
else
@ -387,81 +406,153 @@ begin
end;
function TJSWriter.EscapeString(const S: TJSString; Quote: TJSEscapeQuote
): String;
): TJSString;
Var
I,J,L : Integer;
P : TJSPChar;
R: TJSString;
begin
I:=1;
J:=1;
Result:='';
R:='';
L:=Length(S);
P:=TJSPChar(S);
While I<=L do
begin
if (P^ in [#0..#31,'"','''','/','\']) then
begin
Result:=Result+JSStringToStr(Copy(S,J,I-J));
R:=R+Copy(S,J,I-J);
Case P^ of
'\' : Result:=Result+'\\';
'/' : Result:=Result+'\/';
'"' : if Quote=jseqSingle then Result:=Result+'"' else Result:=Result+'\"';
'''': if Quote=jseqDouble then Result:=Result+'''' else Result:=Result+'\''';
#0..#7,#11,#14..#31: Result:=Result+'\x'+hexStr(ord(P^),2);
#8 : Result:=Result+'\b';
#9 : Result:=Result+'\t';
#10 : Result:=Result+'\n';
#12 : Result:=Result+'\f';
#13 : Result:=Result+'\r';
'\' : R:=R+'\\';
'/' : R:=R+'\/';
'"' : if Quote=jseqSingle then R:=R+'"' else R:=R+'\"';
'''': if Quote=jseqDouble then R:=R+'''' else R:=R+'\''';
#0..#7,#11,#14..#31: R:=R+'\x'+TJSString(hexStr(ord(P^),2));
#8 : R:=R+'\b';
#9 : R:=R+'\t';
#10 : R:=R+'\n';
#12 : R:=R+'\f';
#13 : R:=R+'\r';
end;
J:=I+1;
end;
Inc(I);
Inc(P);
end;
Result:=Result+JSStringToStr(Copy(S,J,I-1));
end;
function TJSWriter.JSStringToStr(const S: TJSString): string;
begin
if UseUTF8 then
Result:=UTF8Encode(S)
else
Result:=String(S);
R:=R+Copy(S,J,I-1);
Result:=R;
end;
procedure TJSWriter.WriteValue(V: TJSValue);
const
TabWidth = 4;
function GetLineIndent(var p: PWideChar): integer;
var
h: PWideChar;
begin
h:=p;
Result:=0;
repeat
case h^ of
#0: break;
#9: Result:=Result+(TabWidth-Result mod TabWidth);
' ': inc(Result);
else break;
end;
inc(h);
until false;
p:=h;
end;
function SkipToNextLineStart(p: PWideChar): PWideChar;
begin
repeat
case p^ of
#0: break;
#10,#13:
begin
if (p[1] in [#10,#13]) and (p^<>p[1]) then
inc(p,2)
else
inc(p);
break;
end
else inc(p);
end;
until false;
Result:=p;
end;
Var
S : String;
JS: TJSString;
p, StartP: PWideChar;
MinIndent, CurLineIndent: Integer;
begin
if V.CustomValue<>'' then
S:=JSStringToStr(V.CustomValue)
else
Case V.ValueType of
jstUNDEFINED : S:='undefined';
jstNull : s:='null';
jstBoolean : if V.AsBoolean then s:='true' else s:='false';
jstString :
begin
JS:=V.AsString;
if Pos('"',JS)>0 then
S:=''''+EscapeString(JS,jseqSingle)+''''
else
S:='"'+EscapeString(JS,jseqDouble)+'"';
end;
jstNumber :
if Frac(V.AsNumber)=0 then // this needs to be improved
Str(Round(V.AsNumber),S)
else
Str(V.AsNumber,S);
jstObject : ;
jstReference : ;
JSTCompletion : ;
begin
JS:=V.CustomValue;
if JS='' then exit;
p:=SkipToNextLineStart(PWideChar(JS));
if p^=#0 then
begin
// simple value
Write(JS);
exit;
end;
// multi line value
// find minimum indent
MinIndent:=-1;
repeat
CurLineIndent:=GetLineIndent(p);
if (MinIndent<0) or (MinIndent>CurLineIndent) then
MinIndent:=CurLineIndent;
p:=SkipToNextLineStart(p);
until p^=#0;
// write value lines indented
p:=PWideChar(JS);
GetLineIndent(p); // the first line is already indented, skip
repeat
StartP:=p;
p:=SkipToNextLineStart(StartP);
Write(copy(JS,StartP-PWideChar(JS)+1,p-StartP));
if p^=#0 then break;
CurLineIndent:=GetLineIndent(p);
Write(StringOfChar(FIndentChar,FCurIndent+CurLineIndent-MinIndent));
until false;
exit;
end;
Case V.ValueType of
jstUNDEFINED : S:='undefined';
jstNull : s:='null';
jstBoolean : if V.AsBoolean then s:='true' else s:='false';
jstString :
begin
JS:=V.AsString;
if Pos('"',JS)>0 then
JS:=''''+EscapeString(JS,jseqSingle)+''''
else
JS:='"'+EscapeString(JS,jseqDouble)+'"';
Write(JS);
exit;
end;
jstNumber :
if Frac(V.AsNumber)=0 then // this needs to be improved
Str(Round(V.AsNumber),S)
else
Str(V.AsNumber,S);
jstObject : ;
jstReference : ;
JSTCompletion : ;
end;
Write(S);
end;
@ -680,10 +771,24 @@ end;
procedure TJSWriter.WriteMemberExpression(El: TJSMemberExpression);
var
MExpr: TJSElement;
begin
if El is TJSNewMemberExpression then
Write('new ');
WriteJS(El.MExpr);
MExpr:=El.MExpr;
if (MExpr is TJSPrimaryExpression)
or (MExpr is TJSDotMemberExpression)
or (MExpr is TJSBracketMemberExpression)
or (MExpr is TJSCallExpression)
or (MExpr is TJSLiteral) then
WriteJS(MExpr)
else
begin
Write('(');
WriteJS(MExpr);
Write(')');
end;
if El is TJSDotMemberExpression then
begin
write('.');
@ -1309,23 +1414,23 @@ begin
Result:=DoWrite(S);
end;
Function TTextWriter.Write(Const S: String) : integer;
Function TTextWriter.Write(Const S: AnsiString) : integer;
begin
Result:=DoWrite(S);
end;
Function TTextWriter.WriteLn(Const S: String) : Integer;
Function TTextWriter.WriteLn(Const S: AnsiString) : Integer;
begin
Result:=DoWrite(S)+DoWrite(sLineBreak);
end;
Function TTextWriter.Write(Const Fmt: String; Args: Array of const) : Integer;
Function TTextWriter.Write(Const Fmt: AnsiString; Args: Array of const) : Integer;
begin
Result:=DoWrite(Format(Fmt,Args));
end;
Function TTextWriter.WriteLn(Const Fmt: String; Args: Array of const) : integer;
Function TTextWriter.WriteLn(Const Fmt: AnsiString; Args: Array of const) : integer;
begin
Result:=WriteLn(Format(Fmt,Args));
end;

40
packages/fcl-json/src/fpjsonrtti.pp
View File

@ -28,7 +28,10 @@ Type
jsoDateTimeAsString, // Format a TDateTime value as a string
jsoUseFormatString, // Use FormatString when creating JSON strings.
jsoCheckEmptyDateTime, // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string
jsoLegacyDateTime); // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
jsoLegacyDateTime, // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
jsoLowerPropertyNames, // Set this to force lowercase names when streaming to JSON.
jsoStreamTList // Set this to assume that TList contains a list of TObjects. Use with care!
);
TJSONStreamOptions = Set of TJSONStreamOption;
TJSONFiler = Class(TComponent)
@ -70,6 +73,8 @@ Type
function StreamCollection(Const ACollection: TCollection): TJSONArray;
// Stream an objectlist - always returns an array
function StreamObjectList(Const AnObjectList: TObjectList): TJSONArray;
// Stream a List - always returns an array
function StreamTList(Const AList: TList): TJSONArray;
// Stream a TStrings instance as an array
function StreamTStringsArray(Const AStrings: TStrings): TJSONArray;
// Stream a TStrings instance as an object
@ -406,6 +411,7 @@ Var
PI : PPropInfo;
TI : PTypeInfo;
I,J,S : Integer;
D : Double;
A : TJSONArray;
JS : TJSONStringType;
begin
@ -550,6 +556,8 @@ procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONData;
Var
I : integer;
A : TJSONArray;
O : TJSONObject;
begin
If (JSON.JSONType=jtArray) then
A:=JSON As TJSONArray
@ -738,6 +746,8 @@ begin
Result.Add('Items',StreamCollection(TCollection(AObject)))
else If AObject is TObjectList then
Result.Add('Objects',StreamObjectList(TObjectList(AObject)))
else if (jsoStreamTlist in Options) and (AObject is TList) then
Result := TJSONObject(StreamTList(TList(AObject)))
else
begin
PIL:=TPropInfoList.Create(AObject,tkProperties);
@ -745,9 +755,13 @@ begin
For I:=0 to PIL.Count-1 do
begin
PD:=StreamProperty(AObject,PIL.Items[i]);
If (PD<>Nil) then
If (PD<>Nil) then begin
if jsoLowerPropertyNames in Options then
Result.Add(LowerCase(PIL.Items[I]^.Name),PD)
else
Result.Add(PIL.Items[I]^.Name,PD);
end;
end;
finally
FReeAndNil(Pil);
end;
@ -893,6 +907,24 @@ begin
end;
end;
function TJSONStreamer.StreamTList(const AList: TList): TJSONArray;
var
I : Integer;
o : TJSONObject;
begin
Result:=TJSONArray.Create;
try
for I:=0 to AList.Count-1 do begin
o := ObjectToJSON(TObject(AList.Items[i]));
if Assigned(o) then
Result.Add(o);
end;
except
FreeAndNil(Result);
Raise;
end;
end;
Function TJSONStreamer.StreamTStringsArray(Const AStrings : TStrings) : TJSONArray;
Var
@ -977,6 +1009,10 @@ end;
function TJSONStreamer.StreamClassProperty(const AObject: TObject): TJSONData;
Var
C : TCollection;
I : integer;
begin
Result:=Nil;
If (AObject=Nil) then

42
packages/fcl-json/tests/testjsonrtti.pp
View File

@ -106,8 +106,10 @@ type
Procedure TestObjectToJSONString;
Procedure TestStringsToJSONString;
Procedure TestCollectionToJSONString;
procedure TestTListToJSONString;
Procedure TestChildren;
Procedure TestChildren2;
Procedure TestLowercase;
end;
{ TTestJSONDeStreamer }
@ -1753,6 +1755,38 @@ begin
end;
end;
procedure TTestJSONStreamer.TestTListToJSONString ;
Var
C : TList;
D : TJSONData;
P : Pointer;
Function Add : TTestItem;
begin
Result:=TTestItem.Create(Nil);
C.Add(Result);
end;
begin
RJ.Options:=RJ.Options + [jsoStreamTList];
C:=TList.Create;
try
Add.StrProp:='one';
Add.StrProp:='two';
Add.StrProp:='three';
D:=RJ.StreamTList(C);
AssertEquals('StreamTlist','[{ "StrProp" : "one" }, { "StrProp" : "two" }, { "StrProp" : "three" }]',D.AsJSON);
finally
D.Free;
For P in C do
TObject(P).Free;
FreeAndNil(C);
end;
end;
procedure TTestJSONStreamer.TestCollectionToJSONString;
Var
@ -1813,6 +1847,14 @@ begin
end;
end;
procedure TTestJSONStreamer.TestLowercase;
begin
RJ.Options:=RJ.Options+[jsoLowerPropertyNames];
StreamObject(TBooleanComponent.Create(nil));
AssertPropCount(1);
AssertProp('booleanprop',False);
end;
initialization
RegisterTests([TTestJSONStreamer,TTestJSONDeStreamer]);

2281
packages/fcl-passrc/src/pasresolver.pp
View File

File diff suppressed because it is too large Load Diff

1
packages/fcl-passrc/src/passrcutil.pp
View File

@ -74,6 +74,7 @@ end;
function TSrcContainer.FindElement(const AName: String): TPasElement;
begin
if AName='' then ;
Result:=Nil;
end;

187
packages/fcl-passrc/src/pastree.pp
View File

@ -82,9 +82,17 @@ type
// Visitor pattern.
TPassTreeVisitor = class;
{ TPasElementBase }
TPasElementBase = class
procedure Accept(Visitor: TPassTreeVisitor); virtual; abstract;
private
FData: TObject;
protected
procedure Accept(Visitor: TPassTreeVisitor); virtual;
public
Property CustomData : TObject Read FData Write FData;
end;
TPasElementBaseClass = class of TPasElementBase;
TPasModule = class;
@ -109,7 +117,6 @@ type
TPasElement = class(TPasElementBase)
private
FData: TObject;
FDocComment: String;
FRefCount: LongWord;
FName: string;
@ -145,7 +152,6 @@ type
property Name: string read FName write FName;
property Parent: TPasElement read FParent Write FParent;
Property Hints : TPasMemberHints Read FHints Write FHints;
Property CustomData : TObject Read FData Write FData;
Property HintMessage : String Read FHintMessage Write FHintMessage;
Property DocComment : String Read FDocComment Write FDocComment;
end;
@ -197,12 +203,16 @@ type
const Arg: Pointer); override;
end;
{ TPrimitiveExpr }
TPrimitiveExpr = class(TPasExpr)
Value : AnsiString;
constructor Create(AParent : TPasElement; AKind: TPasExprKind; const AValue : Ansistring); overload;
function GetDeclaration(full : Boolean) : string; override;
end;
{ TBoolConstExpr }
TBoolConstExpr = class(TPasExpr)
Value : Boolean;
constructor Create(AParent : TPasElement; AKind: TPasExprKind; const ABoolValue : Boolean); overload;
@ -515,7 +525,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
function ElementTypeName: string; override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
Procedure GetEnumNames(Names : TStrings);
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -622,7 +632,7 @@ type
const Arg: Pointer); override;
public
Access: TArgumentAccess;
ArgType: TPasType;
ArgType: TPasType; // can be nil, when Access<>argDefault
ValueExpr: TPasExpr; // the default value
Function Value : String;
end;
@ -723,7 +733,8 @@ type
public
VarType: TPasType;
VarModifiers : TVariableModifiers;
LibraryName,ExportName : string;
LibraryName : TPasExpr; // libname of modifier external
ExportName : TPasExpr; // symbol name of modifier external, export and public
Modifiers : string;
AbsoluteLocation : String;
Expr: TPasExpr;
@ -810,7 +821,7 @@ type
TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
pmExport, pmOverload, pmMessage, pmReintroduce,
pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
pmCompilerProc,pmExternal,pmForward, pmdispid, pmnoreturn);
pmCompilerProc,pmExternal,pmForward, pmDispId, pmNoReturn);
TProcedureModifiers = Set of TProcedureModifier;
TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
@ -1313,17 +1324,20 @@ Type
ExceptAddr : TPasExpr;
end;
{ TPassTreeVisitor }
TPassTreeVisitor = class
procedure Visit(obj: TPasElement); virtual;
end;
{ TPasImplLabelMark }
TPasImplLabelMark = class(TPasImplElement)
public
LabelId: AnsiString;
end;
{ TPassTreeVisitor }
TPassTreeVisitor = class
public
procedure Visit(obj: TPasElement); virtual;
end;
const
AccessNames: array[TArgumentAccess] of string[9] = ('', 'const ', 'var ', 'out ','constref ');
AllVisibilities: TPasMemberVisibilities =
@ -1404,10 +1418,18 @@ uses SysUtils;
procedure ReleaseAndNil(var El: TPasElement);
begin
if El=nil then exit;
{$IFDEF VerbosePasTreeMem}writeln('ReleaseAndNil ',El.Name,' ',El.ClassName);{$ENDIF}
El.Release;
El:=nil;
end;
{ TPasElementBase }
procedure TPasElementBase.Accept(Visitor: TPassTreeVisitor);
begin
if Visitor=nil then ;
end;
{ TPasTypeRef }
procedure TPasTypeRef.ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -1580,8 +1602,11 @@ end;
destructor TPasProgram.Destroy;
begin
{$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy ProgramSection');{$ENDIF}
ReleaseAndNil(TPasElement(ProgramSection));
{$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy inherited');{$ENDIF}
inherited Destroy;
{$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy END');{$ENDIF}
end;
function TPasProgram.ElementTypeName: string;
@ -1845,8 +1870,11 @@ end;
destructor TPasElement.Destroy;
begin
if FRefCount>0 then
if (FRefCount>0) and (FRefCount<high(FRefCount)) then
begin
{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}writeln('TPasElement.Destroy ',Name,':',ClassName);{$ENDIF}
raise Exception.Create('');
end;
inherited Destroy;
end;
@ -1859,24 +1887,32 @@ end;
procedure TPasElement.Release;
{$ifdef debugrefcount}
{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}
Var
Cn : String;
{$endif}
begin
{$ifdef debugrefcount}
CN:=ClassName;
{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}
CN:=ClassName+' '+Name;
CN:=CN+' '+IntToStr(FRefCount);
If Assigned(Parent) then
CN:=CN+' ('+Parent.ClassName+')';
Writeln('Release : ',Cn);
//If Assigned(Parent) then
// CN:=CN+' ('+Parent.ClassName+')';
Writeln('TPasElement.Release : ',Cn);
{$endif}
if FRefCount = 0 then
Free
begin
FRefCount:=High(FRefCount);
Free;
end
else if FRefCount=High(FRefCount) then
begin
{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released OUCH: ',Cn); {$endif}
raise Exception.Create('');
end
else
Dec(FRefCount);
{$ifdef debugrefcount} Writeln('Released : ',Cn); {$endif}
{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released : ',Cn); {$endif}
end;
procedure TPasElement.ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -2012,30 +2048,38 @@ destructor TPasDeclarations.Destroy;
var
i: Integer;
begin
ExportSymbols.Free;
Variables.Free;
Functions.Free;
Classes.Free;
Consts.Free;
Types.Free;
ResStrings.Free;
Properties.Free;
{$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy START');{$ENDIF}
FreeAndNil(ExportSymbols);
FreeAndNil(Properties);
FreeAndNil(Variables);
FreeAndNil(Functions);
FreeAndNil(Classes);
FreeAndNil(Consts);
FreeAndNil(Types);
FreeAndNil(ResStrings);
{$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy Declarations');{$ENDIF}
for i := 0 to Declarations.Count - 1 do
TPasElement(Declarations[i]).Release;
Declarations.Free;
FreeAndNil(Declarations);
{$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy inherited');{$ENDIF}
inherited Destroy;
{$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy END');{$ENDIF}
end;
destructor TPasModule.Destroy;
begin
if Assigned(InterfaceSection) then
InterfaceSection.Release;
if Assigned(ImplementationSection) then
ImplementationSection.Release;
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy interface');{$ENDIF}
ReleaseAndNil(TPasElement(InterfaceSection));
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy implementation');{$ENDIF}
ReleaseAndNil(TPasElement(ImplementationSection));
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy initialization');{$ENDIF}
ReleaseAndNil(TPasElement(InitializationSection));
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy finalization');{$ENDIF}
ReleaseAndNil(TPasElement(FinalizationSection));
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy inherited');{$ENDIF}
inherited Destroy;
{$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy END');{$ENDIF}
end;
@ -2054,7 +2098,7 @@ var
begin
for i := 0 to Modules.Count - 1 do
TPasModule(Modules[i]).Release;
Modules.Free;
FreeAndNil(Modules);
inherited Destroy;
end;
@ -2106,7 +2150,7 @@ var
begin
for i := 0 to Values.Count - 1 do
TPasEnumValue(Values[i]).Release;
Values.Free;
FreeAndNil(Values);
inherited Destroy;
end;
@ -2134,16 +2178,6 @@ begin
end;
destructor TPasSetType.Destroy;
begin
if Assigned(EnumType) then
begin
EnumType.Release;
end;
inherited Destroy;
end;
constructor TPasVariant.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
@ -2158,9 +2192,9 @@ Var
begin
For I:=0 to Values.Count-1 do
TPasElement(Values[i]).Release;
Values.Free;
FreeAndNil(Values);
if Assigned(Members) then
Members.Release;
ReleaseAndNil(TpasElement(Members));
inherited Destroy;
end;
@ -2186,6 +2220,7 @@ begin
S.Free;
end;
Result:=Result+');';
if Full then ;
end;
end;
@ -2214,16 +2249,16 @@ var
begin
for i := 0 to Members.Count - 1 do
TPasVariable(Members[i]).Release;
Members.Free;
FreeAndNil(Members);
if Assigned(VariantEl) then
VariantEl.Release;
ReleaseAndNil(TPasElement(VariantEl));
if Assigned(Variants) then
begin
for i := 0 to Variants.Count - 1 do
TPasVariant(Variants[i]).Release;
Variants.Free;
FreeAndNil(Variants);
end;
inherited Destroy;
@ -2250,17 +2285,17 @@ begin
TPasElement(Members[i]).Release;
for i := 0 to Interfaces.Count - 1 do
TPasElement(Interfaces[i]).Release;
Members.Free;
FreeAndNil(Members);
if Assigned(AncestorType) then
AncestorType.Release;
if Assigned(HelperForType) then
HelperForType.Release;
ReleaseAndNil(TPasElement(GUIDExpr));
Modifiers.Free;
Interfaces.Free;
FreeAndNil(Modifiers);
FreeAndNil(Interfaces);
for i := 0 to GenericTemplateTypes.Count - 1 do
TPasElement(GenericTemplateTypes[i]).Release;
GenericTemplateTypes.Free;
FreeAndNil(GenericTemplateTypes);
inherited Destroy;
end;
@ -2440,6 +2475,8 @@ begin
(e.g. in Constants) }
ReleaseAndNil(TPasElement(VarType));
ReleaseAndNil(TPasElement(Expr));
ReleaseAndNil(TPasElement(LibraryName));
ReleaseAndNil(TPasElement(ExportName));
inherited Destroy;
end;
@ -2492,7 +2529,7 @@ var
begin
for i := 0 to Overloads.Count - 1 do
TPasProcedure(Overloads[i]).Release;
Overloads.Free;
FreeAndNil(Overloads);
inherited Destroy;
end;
@ -2559,7 +2596,7 @@ begin
for i := 0 to Locals.Count - 1 do
TPasElement(Locals[i]).Release;
Locals.Free;
FreeAndNil(Locals);
if Assigned(ProcType) then
ProcType.Release;
@ -2592,7 +2629,7 @@ end;
destructor TPasImplCommands.Destroy;
begin
Commands.Free;
FreeAndNil(Commands);
inherited Destroy;
end;
@ -2708,7 +2745,7 @@ var
begin
for i := 0 to Elements.Count - 1 do
TPasImplElement(Elements[i]).Release;
Elements.Free;
FreeAndNil(Elements);
inherited Destroy;
end;
@ -2882,6 +2919,7 @@ end;
function TPasModule.GetDeclaration(full : boolean): string;
begin
Result := 'Unit ' + Name;
if full then ;
end;
procedure TPasModule.ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -3114,6 +3152,12 @@ begin
end;
end;
destructor TPasSetType.Destroy;
begin
ReleaseAndNil(TPasElement(EnumType));
inherited Destroy;
end;
function TPasSetType.GetDeclaration (full : boolean) : string;
Var
@ -3763,6 +3807,7 @@ end;
procedure TPassTreeVisitor.Visit(obj: TPasElement);
begin
// Needs to be implemented by descendents.
if Obj=nil then ;
end;
{ TPasSection }
@ -3777,11 +3822,14 @@ destructor TPasSection.Destroy;
var
i: Integer;
begin
{$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy UsesList');{$ENDIF}
for i := 0 to UsesList.Count - 1 do
TPasType(UsesList[i]).Release;
FreeAndNil(UsesList);
{$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy inherited');{$ENDIF}
inherited Destroy;
{$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy END');{$ENDIF}
end;
procedure TPasSection.AddUnitToUsesList(const AUnitName: string);
@ -4105,9 +4153,10 @@ end;
{ TPrimitiveExpr }
function TPrimitiveExpr.GetDeclaration(Full : Boolean):AnsiString;
function TPrimitiveExpr.GetDeclaration(full: Boolean): string;
begin
Result:=Value;
if full then ;
end;
constructor TPrimitiveExpr.Create(AParent : TPasElement; AKind: TPasExprKind; const AValue : Ansistring);
@ -4124,13 +4173,14 @@ begin
Value:=ABoolValue;
end;
Function TBoolConstExpr.GetDeclaration(Full: Boolean):AnsiString;
function TBoolConstExpr.GetDeclaration(full: Boolean): string;
begin
If Value then
Result:='True'
else
Result:='False';
Result:='False';
if full then ;
end;
@ -4343,6 +4393,7 @@ var
begin
for i:=0 to length(Fields)-1 do
Fields[i].ValueExp.Release;
Fields:=nil;
inherited Destroy;
end;
@ -4354,13 +4405,15 @@ begin
SetLength(Fields, i+1);
Fields[i].Name:=AName;
Fields[i].ValueExp:=Value;
Value.Parent:=Self;
end;
{ TNilExpr }
Function TNilExpr.GetDeclaration(Full :Boolean):AnsiString;
function TNilExpr.GetDeclaration(full: Boolean): string;
begin
Result:='Nil';
if full then ;
end;
{ TInheritedExpr }
@ -4368,13 +4421,15 @@ end;
function TInheritedExpr.GetDeclaration(full: Boolean): string;
begin
Result:='Inherited';
if full then ;
end;
{ TSelfExpr }
Function TSelfExpr.GetDeclaration(Full :Boolean):AnsiString;
function TSelfExpr.GetDeclaration(full: Boolean): string;
begin
Result:='Self';
if full then ;
end;
{ TArrayValues }
@ -4416,6 +4471,7 @@ var
begin
for i:=0 to length(Values)-1 do
Values[i].Release;
Values:=nil;
inherited Destroy;
end;
@ -4426,6 +4482,7 @@ begin
i:=length(Values);
SetLength(Values, i+1);
Values[i]:=AValue;
AValue.Parent:=Self;
end;
{ TNilExpr }
@ -4460,7 +4517,7 @@ end;
destructor TPasLabels.Destroy;
begin
Labels.Free;
FreeAndNil(Labels);
inherited Destroy;
end;

434
packages/fcl-passrc/src/pparser.pp
View File

@ -239,7 +239,8 @@ type
function CheckOverloadList(AList: TFPList; AName: String; out OldMember: TPasElement): TPasOverloadedProc;
procedure DumpCurToken(Const Msg : String; IndentAction : TIndentAction = iaNone);
function GetCurrentModeSwitches: TModeSwitches;
function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string;
Procedure SetCurrentModeSwitches(AValue: TModeSwitches);
function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr): string;
function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
@ -367,6 +368,7 @@ type
procedure ParseStatement(Parent: TPasImplBlock; out NewImplElement: TPasImplElement);
procedure ParseLabels(AParent: TPasElement);
procedure ParseProcBeginBlock(Parent: TProcedureBody);
procedure ParseProcAsmBlock(Parent: TProcedureBody);
// Function/Procedure declaration
function ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure;
procedure ParseArgList(Parent: TPasElement;
@ -381,7 +383,7 @@ type
property CurToken: TToken read FCurToken;
property CurTokenString: String read FCurTokenString;
Property Options : TPOptions Read FOptions Write SetOptions;
Property CurrentModeswitches : TModeSwitches Read GetCurrentModeSwitches;
Property CurrentModeswitches : TModeSwitches Read GetCurrentModeSwitches Write SetCurrentModeSwitches;
Property CurModule : TPasModule Read FCurModule;
Property LogEvents : TPParserLogEvents Read FLogEvents Write FLogEvents;
Property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog;
@ -885,7 +887,7 @@ end;
function TPasParser.CurTokenIsIdentifier(const S: String): Boolean;
begin
Result:=(Curtoken=tkidentifier) and (CompareText(S,CurtokenText)=0);
Result:=(Curtoken=tkIdentifier) and (CompareText(S,CurtokenText)=0);
end;
@ -930,7 +932,7 @@ function TPasParser.CheckHint(Element: TPasElement; ExpectSemiColon: Boolean
Var
Found : Boolean;
h : TPasMemberHint;
begin
Result:=[];
Repeat
@ -1421,7 +1423,7 @@ begin
NextToken;
If CurToken=tkOf then
Result.ElType := ParseType(Result,Scanner.CurSourcePos)
else
else
ungettoken;
end;
@ -1447,10 +1449,12 @@ var
begin
Result:=nil;
if paramskind in [pekArrayParams, pekSet] then begin
if CurToken<>tkSquaredBraceOpen then Exit;
if CurToken<>tkSquaredBraceOpen then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['[']);
PClose:=tkSquaredBraceClose;
end else begin
if CurToken<>tkBraceOpen then Exit;
if CurToken<>tkBraceOpen then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['(']);
PClose:=tkBraceClose;
end;
@ -1461,11 +1465,12 @@ begin
if not isEndOfExp then begin
repeat
p:=DoParseExpression(params);
if not Assigned(p) then Exit; // bad param syntax
if not Assigned(p) then
ParseExcSyntaxError;
params.AddParam(p);
if (CurToken=tkColon) then
if Not AllowFormatting then
ParseExcSyntaxError
ParseExc(nParserExpectTokenError,SParserExpectTokenError,[','])
else
begin
NextToken;
@ -1476,15 +1481,14 @@ begin
p.format2:=DoParseExpression(p);
end;
end;
if not (CurToken in [tkComma, PClose]) then begin
Exit;
end;
if not (CurToken in [tkComma, PClose]) then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,[',']);
if CurToken = tkComma then begin
NextToken;
if CurToken = PClose then begin
//ErrorExpected(parser, 'identifier');
Exit;
ParseExcSyntaxError;
end;
end;
until CurToken=PClose;
@ -1512,7 +1516,7 @@ begin
tkLessEqualThan : Result:=eopLessthanEqual;
tkGreaterEqualThan : Result:=eopGreaterThanEqual;
tkPower : Result:=eopPower;
tkSymmetricalDifference : Result:=eopSymmetricalDifference;
tkSymmetricalDifference : Result:=eopSymmetricalDifference;
tkIs : Result:=eopIs;
tkAs : Result:=eopAs;
tkSHR : Result:=eopSHR;
@ -1530,7 +1534,7 @@ begin
ParseExc(nParserNotAnOperand,SParserNotAnOperand,[AToken,TokenInfos[AToken]]);
end;
end;
function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
Function IsWriteOrstr(P : TPasExpr) : boolean;
@ -1546,6 +1550,30 @@ function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
Result:=(N='write') or (N='str') or (N='writeln');
end;
end;
Procedure HandleSelf(Var Last: TPasExpr);
Var
b : TBinaryExpr;
optk : TToken;
begin
NextToken;
if CurToken = tkDot then
begin // self.Write(EscapeText(AText));
optk:=CurToken;
NextToken;
b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
if not Assigned(b.right) then
begin
b.Release;
ParseExcExpectedIdentifier;
end;
Last:=b;
end;
UngetToken;
end;
var
Last , Expr: TPasExpr;
prm : TParamsExpr;
@ -1559,7 +1587,16 @@ begin
tkString: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString);
tkChar: Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText);
tkNumber: Last:=CreatePrimitiveExpr(AParent,pekNumber, CurTokenString);
tkIdentifier: Last:=CreatePrimitiveExpr(AParent,pekIdent, CurTokenText);
tkIdentifier:
begin
if CompareText(CurTokenText,'self')=0 then
begin
Last:=CreateSelfExpr(AParent);
HandleSelf(Last)
end
Else
Last:=CreatePrimitiveExpr(AParent,pekIdent, CurTokenText)
end;
tkfalse, tktrue: Last:=CreateBoolConstExpr(Aparent,pekBoolConst, CurToken=tktrue);
tknil: Last:=CreateNilExpr(AParent);
tkSquaredBraceOpen: Last:=ParseParams(AParent,pekSet);
@ -1573,34 +1610,18 @@ begin
b:=CreateBinaryExpr(AParent,Last, DoParseExpression(AParent), eopNone);
if not Assigned(b.right) then
begin
B.Release;
Exit; // error
end;
Last:=b;
UngetToken;
end
else
UngetToken;
end;
tkself:
begin
//Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText); //function(self);
Last:=CreateSelfExpr(AParent);
NextToken;
if CurToken = tkDot then
begin // self.Write(EscapeText(AText));
optk:=CurToken;
NextToken;
b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
if not Assigned(b.right) then
begin
B.Release;
Exit; // error
b.Release;
ParseExcExpectedIdentifier;
end;
Last:=b;
end;
UngetToken;
end;
tkself:
begin
Last:=CreateSelfExpr(AParent);
HandleSelf(Last);
end;
tkAt:
begin
// P:=@function;
@ -1633,7 +1654,7 @@ begin
ok:=false;
try
if Last.Kind=pekIdent then
if Last.Kind in [pekIdent,pekSelf] then
begin
while CurToken in [tkDot] do
begin
@ -1672,14 +1693,20 @@ begin
end;
until false;
// Needed for TSDOBaseDataObjectClass(Self.ClassType).Create
if CurToken in [tkdot,tkas] then
if CurToken in [tkDot,tkas] then
begin
optk:=CurToken;
NextToken;
Expr:=ParseExpIdent(AParent);
if Expr=nil then
Exit; // error
AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk));
ParseExcExpectedIdentifier;
if optk=tkDot then
AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk))
else
begin
// a as b
Result:=CreateBinaryExpr(AParent,Result,Expr,TokenToExprOp(tkas));
end;
end;
end;
ok:=true;
@ -1717,7 +1744,7 @@ var
i : Integer;
tempop : TToken;
NotBinary : Boolean;
const
PrefixSym = [tkPlus, tkMinus, tknot, tkAt]; // + - not @
BinaryOP = [tkMul, tkDivision, tkdiv, tkmod, tkDotDot,
@ -1906,10 +1933,12 @@ end;
function GetExprIdent(p: TPasExpr): String;
begin
if Assigned(p) and (p is TPrimitiveExpr) and (p.Kind=pekIdent) then
Result:='';
if not Assigned(p) then exit;
if (p.ClassType=TPrimitiveExpr) and (p.Kind=pekIdent) then
Result:=TPrimitiveExpr(p).Value
else
Result:='';
else if (p.ClassType=TSelfExpr) then
Result:='Self';
end;
function TPasParser.DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
@ -1937,50 +1966,77 @@ begin
if CurToken <> tkBraceOpen then
Result:=DoParseExpression(AParent)
else begin
Result:=nil;
NextToken;
x:=DoParseConstValueExpression(AParent);
case CurToken of
tkComma: // array of values (a,b,c);
begin
try
a:=CreateArrayValues(AParent);
a.AddValues(x);
x:=nil;
repeat
NextToken;
x:=DoParseConstValueExpression(AParent);
a.AddValues(x);
x:=nil;
until CurToken<>tkComma;
Result:=a;
finally
if Result=nil then
begin
a.Free;
x.Free;
end;
end;
tkColon: // record field (a:xxx;b:yyy;c:zzz);
begin
n:=GetExprIdent(x);
x.Release;
r:=CreateRecordValues(AParent);
NextToken;
x:=DoParseConstValueExpression(AParent);
r.AddField(n, x);
if not lastfield then
repeat
n:=ExpectIdentifier;
ExpectToken(tkColon);
NextToken;
x:=DoParseConstValueExpression(AParent);
r.AddField(n, x)
until lastfield; // CurToken<>tkSemicolon;
Result:=r;
r:=nil;
try
n:=GetExprIdent(x);
ReleaseAndNil(TPasElement(x));
r:=CreateRecordValues(AParent);
NextToken;
x:=DoParseConstValueExpression(AParent);
r.AddField(n, x);
x:=nil;
if not lastfield then
repeat
n:=ExpectIdentifier;
ExpectToken(tkColon);
NextToken;
x:=DoParseConstValueExpression(AParent);
r.AddField(n, x);
x:=nil;
until lastfield; // CurToken<>tkSemicolon;
Result:=r;
finally
if Result=nil then
begin
r.Free;
x.Free;
end;
end;
end;
else
// Binary expression! ((128 div sizeof(longint)) - 3); ;
// Binary expression! ((128 div sizeof(longint)) - 3);
Result:=DoParseExpression(AParent,x);
if CurToken<>tkBraceClose then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
if CurToken<>tkBraceClose then
begin
ReleaseAndNil(TPasElement(Result));
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
end;
NextToken;
if CurToken <> tkSemicolon then // the continue of expresion
if CurToken <> tkSemicolon then // the continue of expression
Result:=DoParseExpression(AParent,Result);
Exit;
end;
if CurToken<>tkBraceClose then
begin
ReleaseAndNil(TPasElement(Result));
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
end;
NextToken;
end;
end;
@ -2336,6 +2392,7 @@ var
if CurBlock=declType then
Engine.FinishScope(stTypeSection,Declarations);
CurBlock:=NewBlock;
Scanner.SetForceCaret(NewBlock=declType);
end;
var
@ -2353,6 +2410,7 @@ var
PT : TProcType;
NamePos: TPasSourcePos;
ok: Boolean;
Proc: TPasProcedure;
begin
CurBlock := declNone;
@ -2455,7 +2513,6 @@ begin
end;
declType:
begin
Scanner.SetForceCaret(True);
TypeEl := ParseTypeDecl(Declarations);
// Scanner.SetForceCaret(OldForceCaret); // It may have been switched off
if Assigned(TypeEl) then // !!!
@ -2586,6 +2643,9 @@ begin
begin
if Declarations is TProcedureBody then
begin
Proc:=Declarations.Parent as TPasProcedure;
if pmAssembler in Proc.Modifiers then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['asm']);
SetBlock(declNone);
ParseProcBeginBlock(TProcedureBody(Declarations));
break;
@ -2600,6 +2660,20 @@ begin
else
ParseExcSyntaxError;
end;
tkasm:
begin
if Declarations is TProcedureBody then
begin
Proc:=Declarations.Parent as TPasProcedure;
if not (pmAssembler in Proc.Modifiers) then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['begin']);
SetBlock(declNone);
ParseProcAsmBlock(TProcedureBody(Declarations));
break;
end
else
ParseExcSyntaxError;
end;
tklabel:
begin
SetBlock(declNone);
@ -2879,7 +2953,7 @@ var
TypeName: String;
NamePos: TPasSourcePos;
OldForceCaret : Boolean;
begin
TypeName := CurTokenString;
NamePos:=Scanner.CurSourcePos;
@ -2923,13 +2997,16 @@ begin
UngetToken;
end;
function TPasParser.GetVariableModifiers(out VarMods: TVariableModifiers; out
Libname, ExportName: string): string;
function TPasParser.GetVariableModifiers(Parent: TPasElement; out
VarMods: TVariableModifiers; out LibName, ExportName: TPasExpr): string;
Var
S : String;
ExtMod: TVariableModifier;
begin
Result := '';
LibName := nil;
ExportName := nil;
VarMods := [];
NextToken;
If CurTokenIsIdentifier('cvar') then
@ -2940,46 +3017,47 @@ begin
NextToken;
end;
s:=LowerCase(CurTokenText);
if Not ((s='external') or (s='public') or (s='export')) then
UngetToken
if s='external' then
ExtMod:=vmExternal
else if (s='public') then
ExtMod:=vmPublic
else if (s='export') then
ExtMod:=vmExport
else
begin
if s='external' then
Include(VarMods,vmexternal)
else if (s='public') then
Include(varMods,vmpublic)
else if (s='export') then
Include(varMods,vmexport);
Result:=Result+';'+CurTokenText;
NextToken;
if (Curtoken<>tksemicolon) then
begin
if (s='external') then
begin
Include(VarMods,vmexternal);
if (CurToken in [tkString,tkIdentifier])
and Not (CurTokenIsIdentifier('name')) then
begin
Result := Result + ' ' + CurTokenText;
LibName:=CurTokenText;
NextToken;
end;
end;
if CurTokenIsIdentifier('name') then
begin
Result := Result + ' name ';
NextToken;
if (CurToken in [tkString,tkIdentifier]) then
Result := Result + CurTokenText
else
ParseExcSyntaxError;
ExportName:=CurTokenText;
NextToken;
end
else
ParseExcSyntaxError;
end;
UngetToken;
exit;
end;
Include(varMods,ExtMod);
Result:=Result+';'+CurTokenText;
NextToken;
if not (CurToken in [tkString,tkIdentifier]) then
begin
if (CurToken=tkSemicolon) and (ExtMod in [vmExternal,vmPublic]) then
exit;
ParseExcSyntaxError;
end;
// export name exportname;
// public;
// public name exportname;
// external;
// external libname;
// external libname name exportname;
// external name exportname;
if (ExtMod=vmExternal) and (CurToken in [tkString,tkIdentifier])
and Not (CurTokenIsIdentifier('name')) then
begin
Result := Result + ' ' + CurTokenText;
LibName:=DoParseExpression(Parent);
end;
if not CurTokenIsIdentifier('name') then
ParseExcSyntaxError;
NextToken;
if not (CurToken in [tkString,tkIdentifier]) then
ParseExcTokenError(TokenInfos[tkString]);
Result := Result + ' ' + CurTokenText;
ExportName:=DoParseExpression(Parent);
end;
@ -2989,15 +3067,18 @@ procedure TPasParser.ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibi
var
i, OldListCount: Integer;
Value : TPasExpr;
Value , aLibName, aExpName: TPasExpr;
VarType: TPasType;
VarEl: TPasVariable;
H : TPasMemberHints;
VarMods: TVariableModifiers;
D,Mods,Loc,aLibName,aExpName : string;
D,Mods,Loc: string;
OldForceCaret,ok: Boolean;
begin
Value:=Nil;
aLibName:=nil;
aExpName:=nil;
OldListCount:=VarList.Count;
ok:=false;
try
@ -3025,22 +3106,22 @@ begin
VarEl:=TPasVariable(VarList[i]);
// Writeln(VarEl.Name, AVisibility);
VarEl.VarType := VarType;
//VarType.Parent := VarEl; // this is wrong for references types
//VarType.Parent := VarEl; // this is wrong for references
if (i>=OldListCount) then
VarType.AddRef;
end;
Value:=Nil;
H:=CheckHint(Nil,False);
If Full then
GetVariableValueAndLocation(Parent,Value,Loc);
if (Value<>nil) and (VarList.Count>OldListCount+1) then
ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized);
TPasVariable(VarList[OldListCount]).Expr:=Value;
Value:=nil;
H:=H+CheckHint(Nil,Full);
if Full then
Mods:=GetVariableModifiers(VarMods,aLibName,aExpName)
Mods:=GetVariableModifiers(Parent,VarMods,aLibName,aExpName)
else
begin
NextToken;
@ -3061,15 +3142,26 @@ begin
VarEl.Modifiers:=Mods;
VarEl.VarModifiers:=VarMods;
VarEl.AbsoluteLocation:=Loc;
VarEl.LibraryName:=aLibName;
VarEl.ExportName:=aExpName;
if aLibName<>nil then
begin
VarEl.LibraryName:=aLibName;
aLibName.AddRef;
end;
if aExpName<>nil then
begin
VarEl.ExportName:=aExpName;
aExpName.AddRef;
end;
end;
for i := OldListCount to VarList.Count - 1 do
Engine.FinishScope(stDeclaration,TPasVariable(VarList[i]));
ok:=true;
finally
if aLibName<>nil then aLibName.Release;
if aExpName<>nil then aExpName.Release;
if not ok then
begin
if Value<>nil then Value.Release;
for i:=OldListCount to VarList.Count-1 do
TPasElement(VarList[i]).Release;
VarList.Count:=OldListCount;
@ -3319,11 +3411,11 @@ begin
NextToken;
if CurToken in [tkString,tkIdentifier] then
begin
// extrenal libname
// external libname
// external libname name XYZ
// external name XYZ
Tok:=UpperCase(CurTokenString);
if Not ((curtoken=tkIdentifier) and (Tok='NAME')) then
if Not ((CurToken=tkIdentifier) and (Tok='NAME')) then
begin
E:=DoParseExpression(Parent);
if Assigned(P) then
@ -3334,7 +3426,7 @@ begin
else
begin
Tok:=UpperCase(CurTokenString);
if ((curtoken=tkIdentifier) and (Tok='NAME')) then
if ((CurToken=tkIdentifier) and (Tok='NAME')) then
begin
NextToken;
if not (CurToken in [tkString,tkIdentifier]) then
@ -3407,6 +3499,35 @@ end;
procedure TPasParser.ParseProcedureOrFunctionHeader(Parent: TPasElement;
Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
Function FindInSection(AName : String;ASection : TPasSection) : Boolean;
Var
I : integer;
Cn,FN : String;
CT : TPasClassType;
begin
// ToDo: add an event for the resolver to use a faster lookup
I:=ASection.Functions.Count-1;
While (I>=0) and (CompareText(TPasElement(ASection.Functions[I]).Name,AName)<>0) do
Dec(I);
Result:=I<>-1;
I:=Pos('.',AName);
if (Not Result) and (I<>0) then
begin
CN:=Copy(AName,1,I-1);
FN:=Aname;
Delete(FN,1,I);
I:=Asection.Classes.Count-1;
While Not Result and (I>=0) do
begin
CT:=TPasClassType(ASection.Classes[i]);
if CompareText(CT.Name,CN)=0 then
Result:=CT.FindMember(TPasFunction, FN)<>Nil;
Dec(I);
end;
end;
end;
procedure ConsumeSemi;
begin
NextToken;
@ -3441,6 +3562,7 @@ Var
Done: Boolean;
ResultEl: TPasResultElement;
I : Integer;
OK : Boolean;
begin
// Element must be non-nil. Removed all checks for not-nil.
@ -3457,17 +3579,15 @@ begin
end
// In Delphi mode, the implementation in the implementation section can be without result as it was declared
// We actually check if the function exists in the interface section.
else if (msDelphi in CurrentModeswitches) and Assigned(CurModule.ImplementationSection) then
else if (msDelphi in CurrentModeswitches) and
(Assigned(CurModule.ImplementationSection) or
(CurModule is TPasProgram)) then
begin
I:=-1;
if Assigned(CurModule.InterfaceSection) then
begin
// ToDo: add an event for the resolver to use a faster lookup
I:=CurModule.InterfaceSection.Functions.Count-1;
While (I>=0) and (CompareText(TPasElement(CurModule.InterfaceSection.Functions[i]).Name,Parent.Name)<>0) do
Dec(I);
end;
if (I=-1) then
OK:=FindInSection(Parent.Name,CurModule.InterfaceSection)
else if (CurModule is TPasProgram) and Assigned(TPasProgram(CurModule).ProgramSection) then
OK:=FindInSection(Parent.Name,TPasProgram(CurModule).ProgramSection);
if Not OK then
CheckToken(tkColon)
else
begin
@ -3505,7 +3625,7 @@ begin
begin
ExpectToken(tkObject);
Element.IsOfObject := True;
end
end
else if (curToken = tkIs) then
begin
expectToken(tkIdentifier);
@ -3514,8 +3634,8 @@ begin
Element.IsNested:=True;
end
else
UnGetToken;
end;
UnGetToken;
end;
NextToken;
if CurToken = tkEqual then
begin
@ -3666,6 +3786,17 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
ExpectToken(tkSquaredBraceClose);
Result := Result + ']';
end;
repeat
NextToken;
if CurToken <> tkDot then
begin
UngetToken;
break;
end;
ExpectIdentifier;
Result := Result + '.' + CurTokenString;
AddToBinaryExprChain(Expr,Last,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
until false;
end;
var
@ -3789,7 +3920,6 @@ var
BeginBlock: TPasImplBeginBlock;
SubBlock: TPasImplElement;
begin
BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent));
Parent.Body := BeginBlock;
repeat
@ -3809,7 +3939,17 @@ begin
// writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring);
end;
procedure TPasParser.ParseAsmBlock(AsmBlock : TPasImplAsmStatement);
procedure TPasParser.ParseProcAsmBlock(Parent: TProcedureBody);
var
AsmBlock: TPasImplAsmStatement;
begin
AsmBlock:=TPasImplAsmStatement(CreateElement(TPasImplAsmStatement,'',Parent));
Parent.Body:=AsmBlock;
ParseAsmBlock(AsmBlock);
ExpectToken(tkSemicolon);
end;
procedure TPasParser.ParseAsmBlock(AsmBlock: TPasImplAsmStatement);
begin
if po_asmwhole in Options then
begin
@ -3917,9 +4057,9 @@ begin
while True do
begin
NextToken;
//WriteLn(i,'Token=',CurTokenText);
//WriteLn('Token=',CurTokenText);
case CurToken of
tkasm :
tkasm:
begin
El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock));
ParseAsmBlock(TPasImplAsmStatement(El));
@ -3940,9 +4080,10 @@ begin
begin
NextToken;
Left:=DoParseExpression(CurBlock);
UNgettoken;
UngetToken;
El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock));
TPasImplIfElse(El).ConditionExpr:=Left;
Left.Parent:=El;
//WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText);
CreateBlock(TPasImplIfElse(El));
ExpectToken(tkthen);
@ -4003,8 +4144,8 @@ begin
begin
// while Condition do
NextToken;
left:=DoParseExpression(Parent);
ungettoken;
left:=DoParseExpression(CurBlock);
UngetToken;
//WriteLn(i,'WHILE Condition="',Condition,'" Token=',CurTokenText);
El:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock));
TPasImplWhileDo(El).ConditionExpr:=left;
@ -4013,7 +4154,7 @@ begin
end;
tkgoto:
begin
nexttoken;
NextToken;
curblock.AddCommand('goto '+curtokenstring);
expecttoken(tkSemiColon);
end;
@ -4080,17 +4221,18 @@ begin
// with Expr, Expr do
SrcPos:=Scanner.CurSourcePos;
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
TPasImplWithDo(El).AddExpression(Left);
Left.Parent:=El;
CreateBlock(TPasImplWithDo(El));
repeat
if CurToken=tkdo then break;
if CurToken<>tkComma then
ParseExcTokenError(TokenInfos[tkdo]);
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
TPasImplWithDo(CurBlock).AddExpression(Left);
until false;
@ -4098,7 +4240,7 @@ begin
tkcase:
begin
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
UngetToken;
//writeln(i,'CASE OF Expr="',Expr,'" Token=',CurTokenText);
ExpectToken(tkof);
@ -4299,7 +4441,7 @@ begin
if CurBlock is TPasImplRepeatUntil then
begin
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
UngetToken;
TPasImplRepeatUntil(CurBlock).ConditionExpr:=Left;
//WriteLn(i,'UNTIL Condition="',Condition,'" Token=',CurTokenString);
@ -4308,7 +4450,7 @@ begin
ParseExcSyntaxError;
end;
else
left:=DoParseExpression(Parent);
left:=DoParseExpression(CurBlock);
case CurToken of
tkAssign,
tkAssignPlus,
@ -4319,7 +4461,7 @@ begin
// assign statement
Ak:=TokenToAssignKind(CurToken);
NextToken;
right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG
right:=DoParseExpression(CurBlock); // this may solve TPasImplWhileDo.AddElement BUG
El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock));
left.Parent:=El;
right.Parent:=El;
@ -4528,6 +4670,12 @@ begin
Result:=[msNone];
end;
procedure TPasParser.SetCurrentModeSwitches(AValue: TModeSwitches);
begin
if Assigned(FScanner) then
FScanner.CurrentModeSwitches:=AValue;
end;
// Starts on first token after Record or (. Ends on AEndToken
procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
AEndToken: TToken; AllowMethods: Boolean);

59
packages/fcl-passrc/src/pscanner.pp
View File

@ -383,7 +383,8 @@ type
po_asmwhole, // store whole text between asm..end in TPasImplAsmStatement.Tokens
po_nooverloadedprocs, // do not create TPasOverloadedProc for procs with same name
po_keepclassforward, // disabled: delete class fowards when there is a class declaration
po_arrayrangeexpr // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
po_arrayrangeexpr, // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
po_selftoken // Self is a token. For backward compatibility.
);
TPOptions = set of TPOption;
@ -929,6 +930,7 @@ begin
S:=FindStream(AName,ScanIncludes);
If (S<>Nil) then
begin
S.Position:=0;
SL:=TStreamLineReader.Create(AName);
try
SL.InitFromStream(S);
@ -1166,7 +1168,7 @@ end;
function TFileResolver.FindSourceFile(const AName: string): TLineReader;
begin
if not FileExists(AName) then
Raise EFileNotFoundError.create(Aname)
Raise EFileNotFoundError.create(AName)
else
try
Result := CreateFileReader(AName)
@ -1182,7 +1184,7 @@ Var
begin
Result:=Nil;
FN:=FindIncludeFileName(ANAme);
FN:=FindIncludeFileName(AName);
If (FN<>'') then
try
Result := TFileLineReader.Create(FN);
@ -1300,6 +1302,15 @@ begin
tkComment:
if not (FSkipComments or PPIsSkipping) then
Break;
tkSelf:
begin
if Not (po_selftoken in Options) then
begin
FCurToken:=tkIdentifier;
Result:=FCurToken;
end;
Break;
end;
else
if not PPIsSkipping then
break;
@ -2073,35 +2084,25 @@ begin
end;
'0'..'9':
begin
// 1, 12, 1.2, 1.2E3, 1.E2, 1E2, 1.2E-3, 1E+2
// beware of 1..2
TokenStart := TokenStr;
while true do
repeat
Inc(TokenStr);
until not (TokenStr[0] in ['0'..'9']);
if (TokenStr[0]='.') and (TokenStr[1]<>'.') then
begin
inc(TokenStr);
while TokenStr[0] in ['0'..'9'] do
Inc(TokenStr);
end;
if TokenStr[0] in ['e', 'E'] then
begin
Inc(TokenStr);
case TokenStr[0] of
'.':
begin
if TokenStr[1] in ['0'..'9', 'e', 'E'] then
begin
Inc(TokenStr);
repeat
Inc(TokenStr);
until not (TokenStr[0] in ['0'..'9', 'e', 'E']);
end;
break;
end;
'0'..'9': ;
'e', 'E':
begin
Inc(TokenStr);
if TokenStr[0] = '-' then
Inc(TokenStr);
while TokenStr[0] in ['0'..'9'] do
Inc(TokenStr);
break;
end;
else
break;
end;
if TokenStr[0] in ['-','+'] then
inc(TokenStr);
while TokenStr[0] in ['0'..'9'] do
Inc(TokenStr);
end;
SectionLength := TokenStr - TokenStart;
SetLength(FCurTokenString, SectionLength);

41
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -462,6 +462,9 @@ end;
procedure TTestParser.CleanupParser;
begin
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser START');
{$ENDIF}
if Not Assigned(FModule) then
FreeAndNil(FDeclarations)
else
@ -469,17 +472,38 @@ begin
FImplementation:=False;
FEndSource:=False;
FIsUnit:=False;
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FModule');
{$ENDIF}
if Assigned(FModule) then
begin
FModule.Release;
FModule:=nil;
end;
ReleaseAndNil(TPasElement(FModule));
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FSource');
{$ENDIF}
FreeAndNil(FSource);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FParseResult');
{$ENDIF}
FreeAndNil(FParseResult);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FParser');
{$ENDIF}
FreeAndNil(FParser);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FEngine');
{$ENDIF}
FreeAndNil(FEngine);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FScanner');
{$ENDIF}
FreeAndNil(FScanner);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser FResolver');
{$ENDIF}
FreeAndNil(FResolver);
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.CleanupParser END');
{$ENDIF}
end;
procedure TTestParser.ResetParser;
@ -497,8 +521,17 @@ end;
procedure TTestParser.TearDown;
begin
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.TearDown START CleanupParser');
{$ENDIF}
CleanupParser;
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.TearDown inherited');
{$ENDIF}
Inherited;
{$IFDEF VerbosePasResolverMem}
writeln('TTestParser.TearDown END');
{$ENDIF}
end;
procedure TTestParser.CreateEngine(var TheEngine: TPasTreeContainer);

16
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -139,6 +139,7 @@ type
Procedure TestPropertyImplements;
Procedure TestPropertyImplementsFullyQualifiedName;
Procedure TestPropertyReadFromRecordField;
procedure TestPropertyReadFromArrayField;
procedure TestPropertyReadWriteFromRecordField;
Procedure TestLocalSimpleType;
Procedure TestLocalSimpleTypes;
@ -1463,6 +1464,21 @@ begin
Assertequals('Default value','',Property1.DefaultValue);
end;
procedure TTestClassType.TestPropertyReadFromArrayField;
begin
StartVisibility(visPublished);
AddMember('Property Something : Integer Read FPoint.W[x].y.Z');
ParseClass;
AssertProperty(Property1,visPublished,'Something','FPoint.W[x].y.Z','','','',0,False,False);
AssertNotNull('Have type',Property1.VarType);
AssertEquals('Property type class type',TPasUnresolvedTypeRef,Property1.vartype.ClassType);
AssertEquals('Property type name','Integer',Property1.vartype.name);
Assertequals('No index','',Property1.IndexValue);
AssertNull('No Index expression',Property1.IndexExpr);
AssertNull('No default expression',Property1.DefaultExpr);
Assertequals('Default value','',Property1.DefaultValue);
end;
procedure TTestClassType.TestPropertyReadWriteFromRecordField;
begin
StartVisibility(visPublished);

70
packages/fcl-passrc/tests/tcexprparser.pas
View File

@ -45,6 +45,16 @@ type
procedure TestPrimitiveIntegerOctal;
procedure TestPrimitiveIntegerBinary;
procedure TestPrimitiveDouble;
procedure TestPrimitiveDouble2;
procedure TestPrimitiveDouble3;
procedure TestPrimitiveDouble4;
procedure TestPrimitiveDouble5;
procedure TestPrimitiveDouble6;
procedure TestPrimitiveDouble7;
procedure TestPrimitiveDouble8;
procedure TestPrimitiveDouble9;
procedure TestPrimitiveDouble10;
procedure TestPrimitiveDouble11;
procedure TestPrimitiveString;
procedure TestPrimitiveIdent;
procedure TestPrimitiveBooleanFalse;
@ -164,6 +174,66 @@ begin
AssertExpression('Simple double',theExpr,pekNumber,'1.2');
end;
procedure TTestExpressions.TestPrimitiveDouble2;
begin
ParseExpression('1.200');
AssertExpression('Simple double',theExpr,pekNumber,'1.200');
end;
procedure TTestExpressions.TestPrimitiveDouble3;
begin
ParseExpression('01.2');
AssertExpression('Simple double',theExpr,pekNumber,'01.2');
end;
procedure TTestExpressions.TestPrimitiveDouble4;
begin
ParseExpression('1.2e10');
AssertExpression('Simple double',theExpr,pekNumber,'1.2e10');
end;
procedure TTestExpressions.TestPrimitiveDouble5;
begin
ParseExpression('1.2e-10');
AssertExpression('Simple double',theExpr,pekNumber,'1.2e-10');
end;
procedure TTestExpressions.TestPrimitiveDouble6;
begin
ParseExpression('12e10');
AssertExpression('Simple double',theExpr,pekNumber,'12e10');
end;
procedure TTestExpressions.TestPrimitiveDouble7;
begin
ParseExpression('12e-10');
AssertExpression('Simple double',theExpr,pekNumber,'12e-10');
end;
procedure TTestExpressions.TestPrimitiveDouble8;
begin
ParseExpression('8.5');
AssertExpression('Simple double',theExpr,pekNumber,'8.5');
end;
procedure TTestExpressions.TestPrimitiveDouble9;
begin
ParseExpression('8.E5');
AssertExpression('Simple double',theExpr,pekNumber,'8.E5');
end;
procedure TTestExpressions.TestPrimitiveDouble10;
begin
ParseExpression('8.E-5');
AssertExpression('Simple double',theExpr,pekNumber,'8.E-5');
end;
procedure TTestExpressions.TestPrimitiveDouble11;
begin
ParseExpression('8E+5');
AssertExpression('Simple double',theExpr,pekNumber,'8E+5');
end;
procedure TTestExpressions.TestPrimitiveString;
begin
DeclareVar('string');

36
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -28,6 +28,7 @@ type
procedure AssertProc(Mods: TProcedureModifiers; CC: TCallingConvention; ArgCount: Integer; P: TPasProcedure=nil);
function BaseAssertArg(ProcType: TPasProcedureType; AIndex: Integer;
AName: String; AAccess: TArgumentAccess; AValue: String=''): TPasArgument;
procedure CreateForwardTest;
function GetFT: TPasFunctionType;
function GetPT: TPasProcedureType;
Procedure ParseProcedure;
@ -146,6 +147,8 @@ type
Procedure TestFunctionCDeclExport;
Procedure TestProcedureExternal;
Procedure TestFunctionExternal;
Procedure TestFunctionForwardNoReturnDelphi;
procedure TestFunctionForwardNoReturnNoDelphi;
Procedure TestProcedureExternalLibName;
Procedure TestFunctionExternalLibName;
Procedure TestProcedureExternalLibNameName;
@ -1055,6 +1058,39 @@ begin
AssertNull('No Library name expression',Func.LibraryExpr);
end;
procedure TTestProcedureFunction.CreateForwardTest;
begin
With Source do
begin
Add('type');
Add('');
Add('Entity=object');
Add(' function test:Boolean;');
Add('end;');
Add('');
Add('Function Entity.test;');
Add('begin');
Add('end;');
Add('');
Add('begin');
// End is added by ParseModule
end;
end;
procedure TTestProcedureFunction.TestFunctionForwardNoReturnDelphi;
begin
Source.Add('{$MODE DELPHI}');
CreateForwardTest;
ParseModule;
end;
procedure TTestProcedureFunction.TestFunctionForwardNoReturnNoDelphi;
begin
CreateForwardTest;
AssertException('Only in delphi mode can result be omitted',EParserError,@ParseModule);
end;
procedure TTestProcedureFunction.TestProcedureExternalLibName;
begin
ParseProcedure(';external ''libname''','');

1089
packages/fcl-passrc/tests/tcresolver.pas
View File

File diff suppressed because it is too large Load Diff

9
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -82,6 +82,8 @@ type
procedure TestNestedComment3;
procedure TestNestedComment4;
procedure TestIdentifier;
procedure TestSelf;
procedure TestSelfNoToken;
procedure TestString;
procedure TestNumber;
procedure TestChar;
@ -170,7 +172,6 @@ type
procedure TestRecord;
procedure TestRepeat;
procedure TestResourceString;
procedure TestSelf;
procedure TestSet;
procedure TestShl;
procedure TestShr;
@ -1161,9 +1162,15 @@ end;
procedure TTestScanner.TestSelf;
begin
FScanner.Options:=FScanner.Options + [po_selftoken];
TestToken(tkself,'self');
end;
procedure TTestScanner.TestSelfNoToken;
begin
TestToken(tkIdentifier,'self');
end;
procedure TTestScanner.TestSet;

13
packages/fcl-passrc/tests/tcvarparser.pas
View File

@ -273,16 +273,16 @@ procedure TTestVarParser.TestVarExternalLib;
begin
ParseVar('integer; external name ''mylib''','');
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
AssertEquals('Library name','',TheVar.LibraryName);
AssertEquals('Library name','''mylib''',TheVar.ExportName);
AssertNull('Library name',TheVar.LibraryName);
AssertNotNull('Library symbol',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarExternalLibName;
begin
ParseVar('integer; external ''mylib'' name ''de''','');
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
AssertEquals('Library name','''mylib''',TheVar.LibraryName);
AssertEquals('Library name','''de''',TheVar.ExportName);
AssertNotNull('Library name',TheVar.LibraryName);
AssertNotNull('Library symbol',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarCVar;
@ -307,7 +307,7 @@ procedure TTestVarParser.TestVarPublicName;
begin
ParseVar('integer; public name ''ce''','');
AssertEquals('Variable modifiers',[vmpublic],TheVar.VarModifiers);
AssertEquals('Public export name','''ce''',TheVar.ExportName);
AssertNotNull('Public export name',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarDeprecatedExternalName;
@ -315,7 +315,8 @@ begin
ParseVar('integer deprecated; external name ''me''','');
CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'hdeprecated')));
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
AssertEquals('Library name','''me''',TheVar.ExportName);
AssertNull('Library name',TheVar.LibraryName);
AssertNotNull('Library symbol',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarHintPriorToInit;

2
packages/fcl-web/src/base/custcgi.pp
View File

@ -353,7 +353,7 @@ procedure TCGIRequest.InitFromEnvironment;
Var
I : Integer;
R,V,OV : String;
R,V : String;
M : TMap;
begin

92
packages/fcl-web/src/base/fphttpclient.pp
View File

@ -89,6 +89,7 @@ Type
FServerHTTPVersion: String;
FSocket : TInetSocket;
FBuffer : Ansistring;
FTerminated: Boolean;
FUserName: String;
FOnGetSocketHandler : TGetSocketHandlerEvent;
FProxy : TProxyData;
@ -166,6 +167,9 @@ Type
Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer;
// Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet.
Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String;
{ Terminate the current request.
It will stop the client from trying to send and/or receive data after the current chunk is sent/received. }
Procedure Terminate;
// Request Header management
// Return index of header, -1 if not present.
Function IndexOfHeader(Const AHeader : String) : Integer;
@ -262,6 +266,8 @@ Type
Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
// Simple form of Posting a file
Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
// Has Terminate been called ?
Property Terminated : Boolean Read FTerminated;
Protected
// Timeouts
Property IOTimeout : Integer read FIOTimeout write SetIOTimeout;
@ -676,8 +682,9 @@ begin
FSentCookies:=FCookies;
FCookies:=Nil;
S:=S+CRLF;
FSocket.WriteBuffer(S[1],Length(S));
If Assigned(FRequestBody) then
if not Terminated then
FSocket.WriteBuffer(S[1],Length(S));
If Assigned(FRequestBody) and not Terminated then
FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
end;
@ -689,11 +696,13 @@ function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
R : Integer;
begin
if Terminated then
Exit(False);
SetLength(FBuffer,ReadBufLen);
r:=FSocket.Read(FBuffer[1],ReadBufLen);
If r=0 Then
If (r=0) or Terminated Then
Exit(False);
If r<0 then
If (r<0) then
Raise EHTTPClient.Create(SErrReadingSocket);
if (r<ReadBuflen) then
SetLength(FBuffer,r);
@ -746,7 +755,7 @@ begin
Result:=True;
end;
end;
until Result;
until Result or Terminated;
end;
Function GetNextWord(Var S : String) : string;
@ -807,7 +816,7 @@ function TFPCustomHTTPClient.ReadResponseHeaders: integer;
C:=Trim(Copy(S,1,P-1));
Cookies.Add(C);
System.Delete(S,1,P);
Until (S='');
Until (S='') or Terminated;
end;
Const
@ -827,8 +836,8 @@ begin
If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then
DoCookies(S);
end
Until (S='');
If Assigned(FOnHeaders) then
Until (S='') or Terminated;
If Assigned(FOnHeaders) and not Terminated then
FOnHeaders(Self);
end;
@ -990,6 +999,9 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
function FetchData(out Cnt: integer): boolean;
begin
Result:=False;
If Terminated then
exit;
SetLength(FBuffer,ReadBuflen);
Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
If Cnt<0 then
@ -1038,17 +1050,20 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
'0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0');
'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10;
'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10;
else break;
else
break;
end;
if ChunkSize>1000000 then
Raise EHTTPClient.Create(SErrChunkTooBig);
until false;
until Terminated;
// read till line end
while (c<>#10) do
while (c<>#10) and not Terminated do
if ReadData(@c,1)<1 then exit;
if ChunkSize=0 then exit;
// read data
repeat
if Terminated then
exit;
l:=length(FBuffer)-BufPos+1;
if l=0 then
if not FetchData(l) then
@ -1064,14 +1079,18 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
end;
until ChunkSize=0;
// read #13#10
if ReadData(@c,1)<1 then exit;
if c<>#13 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing);
if ReadData(@c,1)<1 then exit;
if c<>#10 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing);
// next chunk
until false;
if ReadData(@c,1)<1 then
exit;
if Not Terminated then
begin
if c<>#13 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing);
if ReadData(@c,1)<1 then exit;
if c<>#10 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing);
// next chunk
end;
until Terminated;
end;
Var
@ -1112,14 +1131,14 @@ begin
LB:=L;
R:=Transfer(LB);
L:=L-R;
until (L=0) or (R=0);
until (L=0) or (R=0) or Terminated;
end
else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then
begin
// No content-length, so we read till no more data available.
Repeat
R:=Transfer(ReadBufLen);
until (R=0);
until (R=0) or Terminated;
end;
end;
end;
@ -1176,7 +1195,8 @@ begin
ConnectToServer(CHost,CPort,AIsHttps);
Try
SendRequest(AMethod,AURI);
ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
if not Terminated then
ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
Finally
DisconnectFromServer;
End;
@ -1199,15 +1219,20 @@ begin
If Not IsConnected Then
ConnectToServer(CHost,CPort,AIsHttps);
Try
SendRequest(AMethod,AURI);
T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
If Not T Then
ReconnectToServer(CHost,CPort,AIsHttps);
if not Terminated then
SendRequest(AMethod,AURI);
if not Terminated then
begin
T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
If Not T Then
ReconnectToServer(CHost,CPort,AIsHttps);
end;
Finally
If HasConnectionClose Then
// On terminate, we close the request
If HasConnectionClose or Terminated Then
DisconnectFromServer;
End;
Until T;
Until T or Terminated;
end;
Procedure TFPCustomHTTPClient.DoMethod(Const AMethod, AURL: String;
@ -1302,6 +1327,11 @@ begin
end;
end;
procedure TFPCustomHTTPClient.Terminate;
begin
FTerminated:=True;
end;
procedure TFPCustomHTTPClient.ResetResponse;
begin
@ -1322,6 +1352,8 @@ Var
RR : Boolean; // Repeat request ?
begin
// Reset Terminated
FTerminated:=False;
L:=AURL;
RC:=0;
RR:=False;
@ -1332,7 +1364,7 @@ begin
else
begin
DoMethod(M,L,Stream,AllowedResponseCodes);
if IsRedirect(FResponseStatusCode) then
if IsRedirect(FResponseStatusCode) and not Terminated then
begin
Inc(RC);
if (RC>MaxRedirects) then
@ -1359,7 +1391,7 @@ begin
end
else
RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'');
until not RR;
until Terminated or not RR ;
end;
procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream);

23
packages/fcl-web/src/base/httpdefs.pp
View File

@ -287,7 +287,6 @@ type
FContentFields: TStrings;
FCookieFields: TStrings;
FHTTPVersion: String;
FHTTPXRequestedWith: String;
FFields : THeadersArray;
FVariables : THTTPVariables;
FQueryFields: TStrings;
@ -299,7 +298,7 @@ type
Function GetFieldCount : Integer;
Function GetContentLength : Integer;
Procedure SetContentLength(Value : Integer);
Function GetFieldOrigin(AIndex : Integer; Out H : THeader; V : THTTPVAriableType) : Boolean;
Function GetFieldOrigin(AIndex : Integer; Out H : THeader; Out V : THTTPVAriableType) : Boolean;
Function GetServerPort : Word;
Procedure SetServerPort(AValue : Word);
Function GetSetFieldValue(Index : Integer) : String; virtual;
@ -412,9 +411,7 @@ type
FFiles : TUploadedFiles;
FReturnedPathInfo : String;
FLocalPathPrefix : string;
FServerPort : String;
FContentRead : Boolean;
FContent : String;
FRouteParams : TStrings;
function GetLocalPathPrefix: string;
function GetFirstHeaderLine: String;
@ -606,9 +603,7 @@ Resourcestring
SErrInternalUploadedFileError = 'Internal uploaded file configuration error';
SErrNoSuchUploadedFile = 'No such uploaded file : "%s"';
SErrUnknownCookie = 'Unknown cookie: "%s"';
SErrUnsupportedContentType = 'Unsupported content type: "%s"';
SErrNoRequestMethod = 'No REQUEST_METHOD passed from server.';
SErrInvalidRequestMethod = 'Invalid REQUEST_METHOD passed from server: %s.';
const
hexTable = '0123456789ABCDEF';
@ -816,7 +811,7 @@ end;
function THTTPHeader.GetFieldOrigin(AIndex: Integer; out H: THeader;
V: THTTPVAriableType): Boolean;
Out V: THTTPVAriableType): Boolean;
begin
@ -1241,10 +1236,9 @@ end;
procedure TMimeItems.CreateUploadFiles(Files: TUploadedFiles; Vars : TStrings);
Var
I,j : Integer;
I : Integer;
P : TMimeItem;
LFN,Name,Value : String;
U : TUploadedFile;
Name,Value : String;
begin
For I:=Count-1 downto 0 do
@ -1798,10 +1792,8 @@ procedure TRequest.ProcessMultiPart(Stream: TStream; const Boundary: String;
Var
L : TMimeItems;
B : String;
I,J : Integer;
S,FF,key, Value : String;
FI : TMimeItem;
F : TStream;
I : Integer;
S : String;
begin
{$ifdef CGIDEBUG} SendMethodEnter('ProcessMultiPart');{$endif CGIDEBUG}
@ -1936,9 +1928,6 @@ end;
procedure TUploadedFile.DeleteTempUploadedFile;
Var
s: String;
begin
if (FStream is TFileStream) then
FreeStream;

14
packages/fcl-web/src/base/httproute.pp
View File

@ -224,6 +224,9 @@ Function RouteMethodToString (R : TRouteMethod) : String;
// Shortcut for THTTPRouter.Service;
Function HTTPRouter : THTTPRouter;
Const
RouteMethodNames : Array[TRouteMethod] of String = ('','','GET','POST','PUT','DELETE','OPTIONS','HEAD','TRACE');
implementation
uses strutils, typinfo;
@ -395,8 +398,17 @@ begin
end;
class function THTTPRouter.StringToRouteMethod(const S: String): TRouteMethod;
begin
Var
MN : String;
begin
Result:=High(TRouteMethod);
MN:=Uppercase(S);
While (Result>=Low(TRouteMethod)) and (RouteMethodNames[Result]<>MN) do
Result:=Pred(Result);
if Result=rmAll then Result:=rmUnknown;
end;
function THTTPRouter.RegisterRoute(const APattern: String;AData : Pointer;

4117
packages/pastojs/src/fppas2js.pp
View File

File diff suppressed because it is too large Load Diff

12
packages/pastojs/tests/tcconverter.pp
View File

@ -268,7 +268,6 @@ begin
E:=TJSExpressionStatement(Convert(R,TJSExpressionStatement));
AssertNotNull('Have call node',E.A);
AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
C:=TJSCallExpression(E.A);
AssertIdentifier('Call expression',C.Expr,'a');
end;
@ -972,12 +971,15 @@ Procedure TTestExpressionConverter.TestBinaryDiv;
Var
B : TBinaryExpr;
E : TJSMultiplicativeExpressionDiv;
C: TJSCallExpression;
Args: TJSArguments;
begin
B:=TBinaryExpr.Create(Nil,pekBinary,eopDiv);
B.left:=CreateLiteral(1.23);
B.Right:=CreateLiteral(3.45);
E:=TJSMultiplicativeExpressionDiv(TestBinaryExpression(B,TJSMultiplicativeExpressionDiv));
C:=TJSCallExpression(Convert(B,TJSCallExpression));
Args:=TJSArguments(AssertElement('Math.floor param',TJSArguments,C.Args));
E:=TJSMultiplicativeExpressionDiv(AssertElement('param',TJSMultiplicativeExpressionDiv,Args.Elements.Elements[0].Expr));
AssertLiteral('Correct left literal for div',E.A,1.23);
AssertLiteral('Correct right literal for div',E.B,3.45);
end;
@ -1013,13 +1015,13 @@ end;
Procedure TTestExpressionConverter.TestBinarySHR;
Var
B : TBinaryExpr;
E : TJSRShiftExpression;
E : TJSURShiftExpression;
begin
B:=TBinaryExpr.Create(Nil,pekBinary,eopSHR);
B.left:=CreateLiteral(13);
B.Right:=CreateLiteral(3);
E:=TJSRShiftExpression(TestBinaryExpression(B,TJSRShiftExpression));
E:=TJSURShiftExpression(TestBinaryExpression(B,TJSURShiftExpression));
AssertLiteral('Correct left literal for shr',E.A,13);
AssertLiteral('Correct right literal for shr',E.B,3);
end;

3965
packages/pastojs/tests/tcmodules.pas
View File

File diff suppressed because it is too large Load Diff

122
utils/pas2js/dist/rtl.js vendored
View File

@ -40,38 +40,50 @@ var rtl = {
rtl.debug('Warn: ',s);
},
isArray: function isArray(a) {
isArray: function(a) {
return a instanceof Array;
},
isNumber: function isNumber(n){
isNumber: function(n){
return typeof(n)=="number";
},
isInteger: function isInteger(A){
isInteger: function(A){
return Math.floor(A)===A;
},
isBoolean: function isBoolean(b){
isBoolean: function(b){
return typeof(b)=="boolean";
},
isString: function isString(s){
isString: function(s){
return typeof(s)=="string";
},
isObject: function isObject(o){
isObject: function(o){
return typeof(o)=="object";
},
isFunction: function isFunction(f){
isFunction: function(f){
return typeof(f)=="function";
},
isNull: function isNull(o){
isNull: function(o){
return (o==null && typeof(o)=='object') || o==undefined;
},
isRecord: function(r){
return (typeof(r)=="function") && (typeof(r.$create) == "function");
},
isClass: function(c){
return (typeof(o)=="object") && (o.$class == o);
},
isClassInstance: function(c){
return (typeof(o)=="object") && (o.$class == Object.getPrototypeOf(o));
},
hasString: function(s){
return rtl.isString(s) && (s.length>0);
},
@ -97,11 +109,12 @@ var rtl = {
run: function(module_name){
if (module_name==undefined) module_name='program';
if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"');
var module = pas[module_name];
rtl.loadintf(module);
rtl.loadimpl(module);
if (module_name=='program'){
rtl.debug('running $main');
if (rtl.debug_load_units) rtl.debug('running $main');
pas.program.$main();
}
return pas.System.ExitCode;
@ -109,14 +122,14 @@ var rtl = {
loadintf: function(module){
if (module.state>rtl.m_loading_intf) return; // already finished
rtl.debug('loadintf: '+module.$name);
if (rtl.debug_load_units) rtl.debug('loadintf: '+module.$name);
if (module.$state==rtl.m_loading_intf)
rtl.error('unit cycle detected "'+module.$name+'"');
module.$state=rtl.m_loading_intf;
// load interfaces of interface useslist
rtl.loaduseslist(module,module.$intfuseslist,rtl.loadintf);
// run interface
rtl.debug('loadintf: run intf of '+module.$name);
if (rtl.debug_load_units) rtl.debug('loadintf: run intf of '+module.$name);
module.$code(module.$intfuseslist,module);
// success
module.$state=rtl.m_intf_loaded;
@ -127,7 +140,7 @@ var rtl = {
if (useslist==undefined) return;
for (var i in useslist){
var unitname=useslist[i];
//rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"');
if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"');
if (pas[unitname]==undefined)
rtl.error('module "'+module.$name+'" misses "'+unitname+'"');
f(pas[unitname]);
@ -137,7 +150,7 @@ var rtl = {
loadimpl: function(module){
if (module.$state>=rtl.m_loading_impl) return; // already processing
if (module.$state<rtl.m_loading_intf) rtl.loadintf(module);
rtl.debug('loadimpl: '+module.$name+' load uses');
if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' load uses');
module.$state=rtl.m_loading_impl;
// load implementation of interfaces useslist
rtl.loaduseslist(module,module.$intfuseslist,rtl.loadimpl);
@ -148,7 +161,7 @@ var rtl = {
// initialized. This is by design.
// run initialization
rtl.debug('loadimpl: '+module.$name+' run init');
if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' run init');
module.$state=rtl.m_initializing;
if (rtl.isFunction(module.$init))
module.$init();
@ -156,12 +169,25 @@ var rtl = {
module.$state=rtl.m_initialized;
},
createCallback: function(scope, fn){
var wrapper = function(){
return fn.apply(scope,arguments);
createCallback: function(scope, fnname){
var cb = function(){
return scope[fnname].apply(scope,arguments);
};
wrapper.fn = fn;
return wrapper;
cb.scope = scope;
cb.fnname = fnname;
return cb;
},
cloneCallback: function(cb){
return rtl.createCallback(cb.scope,cb.fnname);
},
eqCallback: function(a,b){
if (a==null){
return (b==null);
} else {
return (b!=null) && (a.scope==b.scope) && (a.fnname==b.fnname);
}
},
createClass: function(owner,name,ancestor,initfn){
@ -175,14 +201,15 @@ var rtl = {
var o = Object.create(this);
o.$class = this; // Note: o.$class == Object.getPrototypeOf(o)
if (args == undefined) args = [];
o[fnname].apply(o,args);
o.$init();
o[fnname].apply(o,args);
o.AfterConstruction();
return o;
};
c.$destroy = function(fnname){
this.BeforeDestruction();
this[fnname].apply(obj,[]);
this[fnname]();
this.$final;
};
};
c.$classname = name;
@ -197,26 +224,32 @@ var rtl = {
throw pas.System.EInvalidCast.$create("create");
},
setArrayLength: function(arr,newlength,defaultvalue){
if (newlength == 0) return null;
if (arr == null) arr = [];
arraySetLength: function(arr,newlength,defaultvalue){
var oldlen = arr.length;
if (oldlen==newlength) return;
arr.length = newlength;
if (rtl.isArray(defaultvalue)){
for (var i=oldlen; i<newlength; i++) arr[i]=[]; // new array
} else if (rtl.isFunction(defaultvalue)){
for (var i=oldlen; i<newlength; i++) arr[i]=new defaultvalue(); // new record
} else {
for (var i=oldlen; i<newlength; i++) arr[i]=defaultvalue;
}
return arr;
},
setStringLength: function(s,newlength){
s.length = newlength;
},
length: function(a){
return (a!=null) ? a.length : 0;
arrayNewMultiDim: function(dims,defaultvalue){
function create(dim){
if (dim == dims.length-1){
return rtl.arraySetLength([],dims[dim],defaultvalue);
}
var a = [];
var count = dims[dim];
a.length = count;
for(var i=0; i<count; i++) a[i] = create(dim+1);
return a;
};
return create(0);
},
setCharAt: function(s,index,c){
@ -243,9 +276,27 @@ var rtl = {
return r;
},
refSet: function(s){
s.$shared = true;
return s;
},
includeSet: function(s,enumvalue){
if (s.$shared) s = cloneSet(s);
s[enumvalue] = true;
return s;
},
excludeSet: function(s,enumvalue){
if (s.$shared) s = cloneSet(s);
delete s[enumvalue];
return s;
},
diffSet: function(s,t){
var r = {};
for (var key in s) if (s.hasOwnProperty(key) && !t[key]) r[key]=true;
delete r.$shared;
return r;
},
@ -253,12 +304,14 @@ var rtl = {
var r = {};
for (var key in s) if (s.hasOwnProperty(key)) r[key]=true;
for (var key in t) if (t.hasOwnProperty(key)) r[key]=true;
delete r.$shared;
return r;
},
intersectSet: function(s,t){
var r = {};
for (var key in s) if (s.hasOwnProperty(key) && t[key]) r[key]=true;
delete r.$shared;
return r;
},
@ -266,12 +319,13 @@ var rtl = {
var r = {};
for (var key in s) if (s.hasOwnProperty(key) && !t[key]) r[key]=true;
for (var key in t) if (t.hasOwnProperty(key) && !s[key]) r[key]=true;
delete r.$shared;
return r;
},
eqSet: function(s,t){
for (var key in s) if (s.hasOwnProperty(key) && !t[key]) return false;
for (var key in t) if (t.hasOwnProperty(key) && !s[key]) return false;
for (var key in s) if (s.hasOwnProperty(key) && !t[key] && (key!='$shared')) return false;
for (var key in t) if (t.hasOwnProperty(key) && !s[key] && (key!='$shared')) return false;
return true;
},
@ -280,12 +334,12 @@ var rtl = {
},
leSet: function(s,t){
for (var key in s) if (s.hasOwnProperty(key) && !t[key]) return false;
for (var key in s) if (s.hasOwnProperty(key) && !t[key] && (key!='$shared')) return false;
return true;
},
geSet: function(s,t){
for (var key in t) if (t.hasOwnProperty(key) && !s[key]) return false;
for (var key in t) if (t.hasOwnProperty(key) && !s[key] && (key!='$shared')) return false;
return true;
},
}