summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-06-19 08:47:41 +0000
committermarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-06-19 08:47:41 +0000
commit0dde2d08a8bd20fb8b0468e53ef0eb6225b596b3 (patch)
treec7b6deaf40c9694b45752e7d443a5955618ccbe3
parent2f14bc3dc55f260a0303f59a36175066ef0aeac0 (diff)
downloadfpc-0dde2d08a8bd20fb8b0468e53ef0eb6225b596b3.tar.gz
--- Merging r35789 into '.':
U packages/fcl-js/src/jstree.pp --- Recording mergeinfo for merge of r35789 into '.': U . --- Merging r36007 into '.': U packages/pastojs/tests/tcoptimizations.pas --- Recording mergeinfo for merge of r36007 into '.': G . --- Merging r36035 into '.': U packages/pastojs/src/fppas2js.pp U packages/pastojs/tests/tcmodules.pas --- Recording mergeinfo for merge of r36035 into '.': G . --- Merging r36037 into '.': G packages/pastojs/tests/tcmodules.pas G packages/pastojs/src/fppas2js.pp --- Recording mergeinfo for merge of r36037 into '.': G . --- Merging r36070 into '.': G packages/pastojs/tests/tcmodules.pas --- Recording mergeinfo for merge of r36070 into '.': G . --- Merging r36235 into '.': G packages/fcl-js/src/jstree.pp --- Recording mergeinfo for merge of r36235 into '.': G . --- Merging r36471 into '.': G packages/fcl-js/src/jstree.pp --- Recording mergeinfo for merge of r36471 into '.': G . --- Merging r36492 into '.': A packages/fcl-js/tests/tcsrcmap.pas U packages/fcl-js/tests/testjs.lpi U packages/fcl-js/tests/testjs.lpr U packages/fcl-js/src/jswriter.pp A packages/fcl-js/src/jssrcmap.pas --- Recording mergeinfo for merge of r36492 into '.': G . --- Merging r36493 into '.': U packages/fcl-js/src/jssrcmap.pas --- Recording mergeinfo for merge of r36493 into '.': G . --- Merging r36494 into '.': G packages/fcl-js/src/jssrcmap.pas --- Recording mergeinfo for merge of r36494 into '.': G . # revisions: 35789,36007,36035,36037,36070,36235,36471,36492,36493,36494 git-svn-id: https://svn.freepascal.org/svn/fpc/branches/fixes_3_0@36535 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r--packages/fcl-js/src/jssrcmap.pas621
-rw-r--r--packages/fcl-js/src/jstree.pp68
-rw-r--r--packages/fcl-js/src/jswriter.pp151
-rw-r--r--packages/fcl-js/tests/tcsrcmap.pas175
-rw-r--r--packages/fcl-js/tests/testjs.lpi228
-rw-r--r--packages/fcl-js/tests/testjs.lpr2
-rw-r--r--packages/pastojs/src/fppas2js.pp144
-rw-r--r--packages/pastojs/tests/tcmodules.pas139
-rw-r--r--packages/pastojs/tests/tcoptimizations.pas2
9 files changed, 1219 insertions, 311 deletions
diff --git a/packages/fcl-js/src/jssrcmap.pas b/packages/fcl-js/src/jssrcmap.pas
new file mode 100644
index 0000000000..94ca276603
--- /dev/null
+++ b/packages/fcl-js/src/jssrcmap.pas
@@ -0,0 +1,621 @@
+{ *********************************************************************
+ This file is part of the Free Component Library (FCL)
+ Copyright (c) 2015 Mattias Gaertner.
+
+ Javascript Source Map
+
+ See Source Maps Revision 3:
+ https://docs.google.com/document/d/1U1RGAehQwRypUTovF1KRlpiOFze0b-_2gc6fAH0KY0k/edit?hl=en_US&pli=1&pli=1#
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit JSSrcMap;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, contnrs, fpjson;
+
+const
+ Base64Chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
+ DefaultSrcMapHeader = ')]}'+LineEnding;
+
+type
+
+ { TSourceMapSegment }
+
+ TSourceMapSegment = class
+ public
+ Index: integer; // index in FNodes
+ GeneratedLine: integer;
+ GeneratedColumn: integer;
+ SrcFileIndex: integer; // index in FSources
+ SrcLine: integer;
+ SrcColumn: integer;
+ NameIndex: integer; // index in FNames
+ end;
+
+ TSourceMapSrc = class
+ public
+ Filename: string;
+ Source: String;
+ end;
+
+ { TSourceMap }
+
+ TSourceMap = class
+ private
+ type
+
+ { TStringToIndex }
+
+ TStringToIndex = class
+ private
+ FItems: TFPHashList;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ procedure Add(const Value: String; Index: integer);
+ function FindValue(const Value: String): integer;
+ end;
+ private
+ FAddMonotonous: boolean;
+ FHeader: String;
+ FGeneratedFilename: string;
+ FNames: TStrings; // in adding order
+ FNameToIndex: TStringToIndex; // name to index in FNames
+ FItems: TFPList; // TSourceMapSegment, in adding order
+ FSourceRoot: string;
+ FSources: TFPList; // list of TSourceMapSrc, in adding order
+ FSourceToIndex: TStringToIndex; // srcfile to index in FSources
+ FVersion: integer;
+ function GetNames(Index: integer): string;
+ function GetItems(Index: integer): TSourceMapSegment;
+ function GetSourceContents(Index: integer): String;
+ function GetSourceFiles(Index: integer): String;
+ procedure SetGeneratedFilename(const AValue: string);
+ procedure SetSourceContents(Index: integer; const AValue: String);
+ public
+ constructor Create(const aGeneratedFilename: string);
+ destructor Destroy; override;
+ procedure Clear; virtual;
+ function AddMapping(
+ GeneratedLine: integer; // 1-based
+ GeneratedCol: integer = 0; // 0-based
+ const SourceFile: string = ''; // can be empty ''
+ SrcLine: integer = 1; // 1-based
+ SrcCol: integer = 0; // 0-based
+ const Name: String = ''): TSourceMapSegment; virtual;
+ property AddMonotonous: boolean read FAddMonotonous
+ write FAddMonotonous default true;// true = AddMapping GeneratedLine/Col must be behind last add, false = check all adds for duplicate
+ function CreateMappings: String; virtual;
+ function ToJSON: TJSONObject; virtual;
+ procedure SaveToStream(aStream: TStream); virtual;
+ procedure SaveToFile(Filename: string); virtual;
+ function ToString: string; override;
+ property GeneratedFilename: string read FGeneratedFilename write SetGeneratedFilename;
+ function IndexOfName(const Name: string; AddIfNotExists: boolean = false): integer;
+ function IndexOfSourceFile(const SrcFile: string; AddIfNotExists: boolean = false): integer;
+ function Count: integer;
+ property Items[Index: integer]: TSourceMapSegment read GetItems; default; // segments
+ function SourceCount: integer;
+ property SourceRoot: string read FSourceRoot write FSourceRoot;
+ property SourceFiles[Index: integer]: String read GetSourceFiles;
+ property SourceContents[Index: integer]: String read GetSourceContents write SetSourceContents;
+ function NameCount: integer;
+ property Names[Index: integer]: string read GetNames;
+ property Version: integer read FVersion; // 3
+ property Header: String read FHeader write FHeader; // DefaultSrcMapHeader
+ end;
+
+function EncodeBase64VLQ(i: NativeInt): String; // base64 Variable Length Quantity
+function DecodeBase64VLQ(const s: string): NativeInt; // base64 Variable Length Quantity
+function DecodeBase64VLQ(var p: PChar): NativeInt; // base64 Variable Length Quantity
+
+implementation
+
+function EncodeBase64VLQ(i: NativeInt): String;
+{ Convert signed number to base64-VLQ:
+ Each base64 has 6bit, where the most significant bit is the continuation bit
+ (1=there is a next base64 character).
+ The first character contains the 5 least significant bits of the number.
+ The last bit of the first character is the sign bit (1=negative).
+ For example:
+ A = 0 = %000000 => 0
+ B = 1 = %000001 => -0
+ C = 2 = %000010 => 1
+ iF = 34 5 = %100010 %000101 = 00010 00101 = 1000101 = 69
+}
+
+ procedure RaiseRange;
+ begin
+ raise ERangeError.Create('EncodeBase64VLQ');
+ end;
+
+var
+ digits: NativeInt;
+begin
+ Result:='';
+ if i<0 then
+ begin
+ i:=-i;
+ if i>(High(NativeInt)-1) shr 1 then
+ RaiseRange;
+ i:=(i shl 1)+1;
+ end
+ else
+ begin
+ if i>High(NativeInt) shr 1 then
+ RaiseRange;
+ i:=i shl 1;
+ end;
+ repeat
+ digits:=i and %11111;
+ i:=i shr 5;
+ if i>0 then
+ inc(digits,%100000); // need another char -> set continuation bit
+ Result:=Result+Base64Chars[digits+1];
+ until i=0;
+end;
+
+function DecodeBase64VLQ(const s: string): NativeInt;
+var
+ p: PChar;
+begin
+ if s='' then
+ raise EConvertError.Create('DecodeBase64VLQ empty');
+ p:=PChar(s);
+ Result:=DecodeBase64VLQ(p);
+ if p-PChar(s)<>length(s) then
+ raise EConvertError.Create('DecodeBase64VLQ waste');
+end;
+
+function DecodeBase64VLQ(var p: PChar): NativeInt;
+{ Convert base64-VLQ to signed number,
+ For the fomat see EncodeBase64VLQ
+}
+
+ procedure RaiseInvalid;
+ begin
+ raise ERangeError.Create('DecodeBase64VLQ');
+ end;
+
+const
+ MaxShift = 63-5; // actually log2(High(NativeInt))-5
+var
+ c: Char;
+ digit, Shift: Integer;
+begin
+ Result:=0;
+ Shift:=0;
+ repeat
+ c:=p^;
+ case c of
+ 'A'..'Z': digit:=ord(c)-ord('A');
+ 'a'..'z': digit:=ord(c)-ord('a')+26;
+ '0'..'9': digit:=ord(c)-ord('0')+52;
+ '+': digit:=62;
+ '/': digit:=63;
+ else RaiseInvalid;
+ end;
+ inc(p);
+ if Shift>MaxShift then
+ RaiseInvalid;
+ inc(Result,(digit and %11111) shl Shift);
+ inc(Shift,5);
+ until digit<%100000;
+ if (Result and 1)>0 then
+ Result:=-(Result shr 1)
+ else
+ Result:=Result shr 1;
+end;
+
+{ TSourceMap.TStringToIndex }
+
+constructor TSourceMap.TStringToIndex.Create;
+begin
+ FItems:=TFPHashList.Create;
+end;
+
+destructor TSourceMap.TStringToIndex.Destroy;
+begin
+ FItems.Clear;
+ FreeAndNil(FItems);
+ inherited Destroy;
+end;
+
+procedure TSourceMap.TStringToIndex.Clear;
+begin
+ FItems.Clear;
+end;
+
+procedure TSourceMap.TStringToIndex.Add(const Value: String; Index: integer);
+begin
+ // Note: nil=0 means not found in TFPHashList
+ FItems.Add(Value,{%H-}Pointer(PtrInt(Index+1)));
+end;
+
+function TSourceMap.TStringToIndex.FindValue(const Value: String
+ ): integer;
+begin
+ // Note: nil=0 means not found in TFPHashList
+ Result:=integer({%H-}PtrInt(FItems.Find(Value)))-1;
+end;
+
+{ TSourceMap }
+
+procedure TSourceMap.SetGeneratedFilename(const AValue: string);
+begin
+ if FGeneratedFilename=AValue then Exit;
+ FGeneratedFilename:=AValue;
+end;
+
+procedure TSourceMap.SetSourceContents(Index: integer; const AValue: String);
+begin
+ TSourceMapSrc(FSources[Index]).Source:=AValue;
+end;
+
+function TSourceMap.GetItems(Index: integer): TSourceMapSegment;
+begin
+ Result:=TSourceMapSegment(FItems[Index]);
+end;
+
+function TSourceMap.GetSourceContents(Index: integer): String;
+begin
+ Result:=TSourceMapSrc(FSources[Index]).Source;
+end;
+
+function TSourceMap.GetNames(Index: integer): string;
+begin
+ Result:=FNames[Index];
+end;
+
+function TSourceMap.GetSourceFiles(Index: integer): String;
+begin
+ Result:=TSourceMapSrc(FSources[Index]).Filename;
+end;
+
+constructor TSourceMap.Create(const aGeneratedFilename: string);
+begin
+ FVersion:=3;
+ FNames:=TStringList.Create;
+ FNameToIndex:=TStringToIndex.Create;
+ FItems:=TFPList.Create;
+ FSources:=TFPList.Create;
+ FSourceToIndex:=TStringToIndex.Create;
+ FAddMonotonous:=true;
+ FHeader:=DefaultSrcMapHeader;
+ GeneratedFilename:=aGeneratedFilename;
+end;
+
+destructor TSourceMap.Destroy;
+begin
+ Clear;
+ FreeAndNil(FSourceToIndex);
+ FreeAndNil(FSources);
+ FreeAndNil(FItems);
+ FreeAndNil(FNameToIndex);
+ FreeAndNil(FNames);
+ inherited Destroy;
+end;
+
+procedure TSourceMap.Clear;
+var
+ i: Integer;
+begin
+ FSourceToIndex.Clear;
+ for i:=0 to FSources.Count-1 do
+ TObject(FSources[i]).Free;
+ FSources.Clear;
+ for i:=0 to FItems.Count-1 do
+ TObject(FItems[i]).Free;
+ FItems.Clear;
+ FNameToIndex.Clear;
+ FNames.Clear;
+end;
+
+function TSourceMap.AddMapping(GeneratedLine: integer; GeneratedCol: integer;
+ const SourceFile: string; SrcLine: integer; SrcCol: integer;
+ const Name: String): TSourceMapSegment;
+
+ procedure RaiseInvalid(Msg: string);
+ begin
+ raise Exception.CreateFmt('%s (GeneratedLine=%d GeneratedCol=%d SrcFile="%s" SrcLine=%d SrcCol=%d Name="%s")',
+ [Msg,GeneratedLine,GeneratedCol,SourceFile,SrcLine,SrcCol,Name]);
+ end;
+
+var
+ NodeCnt, i: Integer;
+ OtherNode: TSourceMapSegment;
+begin
+ if GeneratedLine<1 then
+ RaiseInvalid('invalid GeneratedLine');
+ if GeneratedCol<0 then
+ RaiseInvalid('invalid GeneratedCol');
+ if SourceFile='' then
+ begin
+ if Count=0 then
+ RaiseInvalid('missing source file');
+ if SrcLine<>1 then
+ RaiseInvalid('invalid SrcLine');
+ if SrcCol<>0 then
+ RaiseInvalid('invalid SrcCol');
+ if Name<>'' then
+ RaiseInvalid('invalid Name');
+ end
+ else
+ begin
+ if SrcLine<1 then
+ RaiseInvalid('invalid SrcLine');
+ if SrcCol<0 then
+ RaiseInvalid('invalid SrcCol');
+ end;
+
+ // check if generated line/col already exists
+ NodeCnt:=Count;
+ if AddMonotonous then
+ begin
+ if NodeCnt>0 then
+ begin
+ OtherNode:=Items[NodeCnt-1];
+ if (OtherNode.GeneratedLine>GeneratedLine)
+ or ((OtherNode.GeneratedLine=GeneratedLine)
+ and (OtherNode.GeneratedColumn>GeneratedCol)) then
+ RaiseInvalid('GeneratedLine/Col not monotonous');
+ // Note: same line/col is allowed
+ end;
+ end
+ else
+ begin
+ for i:=0 to NodeCnt-1 do
+ begin
+ OtherNode:=Items[i];
+ if (OtherNode.GeneratedLine=GeneratedLine) and (OtherNode.GeneratedColumn=GeneratedCol) then
+ RaiseInvalid('duplicate GeneratedLine/Col');
+ end;
+ end;
+
+ // add
+ Result:=TSourceMapSegment.Create;
+ Result.Index:=FItems.Count;
+ Result.GeneratedLine:=GeneratedLine;
+ Result.GeneratedColumn:=GeneratedCol;
+ if SourceFile='' then
+ Result.SrcFileIndex:=-1
+ else
+ Result.SrcFileIndex:=IndexOfSourceFile(SourceFile,true);
+ Result.SrcLine:=SrcLine;
+ Result.SrcColumn:=SrcCol;
+ if Name<>'' then
+ Result.NameIndex:=IndexOfName(Name,true)
+ else
+ Result.NameIndex:=-1;
+ FItems.Add(Result);
+end;
+
+function TSourceMap.CreateMappings: String;
+
+ procedure Add(ms: TMemoryStream; const s: string);
+ begin
+ if s<>'' then
+ ms.Write(s[1],length(s));
+ end;
+
+var
+ ms: TMemoryStream;
+ i, LastGeneratedLine, LastGeneratedColumn, j, LastSrcFileIndex, LastSrcLine,
+ LastSrcColumn, SrcLine, LastNameIndex: Integer;
+ Item: TSourceMapSegment;
+begin
+ Result:='';
+ LastGeneratedLine:=1;
+ LastGeneratedColumn:=0;
+ LastSrcFileIndex:=0;
+ LastSrcLine:=0;
+ LastSrcColumn:=0;
+ LastNameIndex:=0;
+ ms:=TMemoryStream.Create;
+ try
+ for i:=0 to Count-1 do
+ begin
+ Item:=Items[i];
+ if LastGeneratedLine<Item.GeneratedLine then
+ begin
+ // new line
+ LastGeneratedColumn:=0;
+ for j:=LastGeneratedLine+1 to Item.GeneratedLine do
+ ms.WriteByte(ord(';'));
+ LastGeneratedLine:=Item.GeneratedLine;
+ end
+ else if i>0 then
+ begin
+ // not the first segment
+ if (LastGeneratedLine=Item.GeneratedLine)
+ and (LastGeneratedColumn=Item.GeneratedColumn) then
+ continue;
+ ms.WriteByte(ord(','));
+ end;
+ // column diff
+ Add(ms,EncodeBase64VLQ(Item.GeneratedColumn-LastGeneratedColumn));
+ LastGeneratedColumn:=Item.GeneratedColumn;
+
+ if Item.SrcFileIndex<0 then
+ continue; // no source -> segment length 1
+ // src file index diff
+ Add(ms,EncodeBase64VLQ(Item.SrcFileIndex-LastSrcFileIndex));
+ LastSrcFileIndex:=Item.SrcFileIndex;
+ // src line diff
+ SrcLine:=Item.SrcLine-1; // 0 based in version 3
+ Add(ms,EncodeBase64VLQ(SrcLine-LastSrcLine));
+ LastSrcLine:=SrcLine;
+ // src column diff
+ Add(ms,EncodeBase64VLQ(Item.SrcColumn-LastSrcColumn));
+ LastSrcColumn:=Item.SrcColumn;
+ // name index
+ if Item.NameIndex<0 then
+ continue; // no name -> segment length 4
+ Add(ms,EncodeBase64VLQ(Item.NameIndex-LastNameIndex));
+ LastNameIndex:=Item.NameIndex;
+ end;
+ SetLength(Result,ms.Size);
+ if Result<>'' then
+ Move(ms.Memory^,Result[1],ms.Size);
+ finally
+ ms.Free;
+ end;
+end;
+
+function TSourceMap.ToJSON: TJSONObject;
+var
+ Obj: TJSONObject;
+ i: Integer;
+ Arr: TJSONArray;
+ Mappings: String;
+begin
+ Result:=nil;
+ Mappings:=CreateMappings;
+
+ Obj:=TJSONObject.Create;
+ try
+ // "version" - integer
+ Obj.Add('version',Version);
+
+ // "file" - GeneratedFilename
+ if GeneratedFilename<>'' then
+ Obj.Add('file',GeneratedFilename);
+
+ // "sourceRoot" - SourceRoot
+ if SourceRoot<>'' then
+ Obj.Add('sourceRoot',SourceRoot);
+
+ // "sources" - array of filenames
+ Arr:=TJSONArray.Create;
+ Obj.Add('sources',Arr);
+ for i:=0 to SourceCount-1 do
+ Arr.Add(SourceFiles[i]);
+
+ // "sourcesContent" - array of source content: null or source as string
+ // only needed if there is a source
+ i:=SourceCount-1;
+ while i>=0 do
+ if SourceContents[i]='' then
+ dec(i)
+ else
+ begin
+ // there is a source -> add array
+ Arr:=TJSONArray.Create;
+ Obj.Add('sourcesContent',Arr);
+ for i:=0 to SourceCount-1 do
+ if SourceContents[i]='' then
+ Arr.Add(TJSONNull.Create)
+ else
+ Arr.Add(SourceContents[i]);
+ break;
+ end;
+
+ // "names" - array of names
+ Arr:=TJSONArray.Create;
+ Obj.Add('names',Arr);
+ for i:=0 to NameCount-1 do
+ Arr.Add(Names[i]);
+
+ // "mappings" - string
+ Obj.Add('mappings',Mappings);
+
+ Result:=Obj;
+ finally
+ if Result=nil then
+ Obj.Free;
+ end;
+end;
+
+procedure TSourceMap.SaveToStream(aStream: TStream);
+var
+ Obj: TJSONObject;
+begin
+ Obj:=ToJSON;
+ try
+ if Header<>'' then
+ aStream.Write(Header[1],length(Header));
+ Obj.DumpJSON(aStream);
+ finally
+ Obj.Free;
+ end;
+end;
+
+procedure TSourceMap.SaveToFile(Filename: string);
+var
+ TheStream: TMemoryStream;
+begin
+ TheStream:=TMemoryStream.Create;
+ try
+ SaveToStream(TheStream);
+ TheStream.Position:=0;
+ TheStream.SaveToFile(Filename);
+ finally
+ TheStream.Free;
+ end;
+end;
+
+function TSourceMap.ToString: string;
+var
+ Obj: TJSONObject;
+begin
+ Obj:=ToJSON;
+ try
+ Result:=Header+Obj.AsJSON;
+ finally
+ Obj.Free;
+ end;
+end;
+
+function TSourceMap.IndexOfName(const Name: string; AddIfNotExists: boolean
+ ): integer;
+begin
+ Result:=FNameToIndex.FindValue(Name);
+ if (Result>=0) or not AddIfNotExists then exit;
+ Result:=FNames.Count;
+ FNames.Add(Name);
+ FNameToIndex.Add(Name,Result);
+end;
+
+function TSourceMap.IndexOfSourceFile(const SrcFile: string;
+ AddIfNotExists: boolean): integer;
+var
+ Src: TSourceMapSrc;
+begin
+ Result:=FSourceToIndex.FindValue(SrcFile);
+ if (Result>=0) or not AddIfNotExists then exit;
+ Src:=TSourceMapSrc.Create;
+ Src.Filename:=SrcFile;
+ Result:=FSources.Count;
+ FSources.Add(Src);
+ FSourceToIndex.Add(SrcFile,Result);
+end;
+
+function TSourceMap.Count: integer;
+begin
+ Result:=FItems.Count;
+end;
+
+function TSourceMap.SourceCount: integer;
+begin
+ Result:=FSources.Count;
+end;
+
+function TSourceMap.NameCount: integer;
+begin
+ Result:=FNames.Count;
+end;
+
+end.
+
diff --git a/packages/fcl-js/src/jstree.pp b/packages/fcl-js/src/jstree.pp
index 0b6dbbffea..c67ee4ec03 100644
--- a/packages/fcl-js/src/jstree.pp
+++ b/packages/fcl-js/src/jstree.pp
@@ -145,13 +145,13 @@ Type
private
FFlags: TJSElementFlags;
FLine: Integer;
- FRow: Integer;
+ FColumn: Integer;
FSource: String;
Public
- Constructor Create(ALine,ARow : Integer; Const ASource : String = ''); virtual;
+ Constructor Create(ALine,AColumn : Integer; Const ASource : String = ''); virtual;
Property Source : String Read FSource Write FSource;
- Property Row : Integer Read FRow Write FRow;
Property Line : Integer Read FLine Write FLine;
+ Property Column : Integer Read FColumn Write FColumn;
Property Flags : TJSElementFlags Read FFlags Write FFlags;
end;
TJSElementClass = Class of TJSElement;
@@ -170,7 +170,7 @@ Type
private
FValue: TJSValue;
Public
- Constructor Create(ALine,ARow : Integer; Const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; Const ASource : String = ''); override;
Destructor Destroy; override;
Property Value : TJSValue Read FValue Write FValue;
end;
@@ -185,7 +185,7 @@ Type
function GetA(AIndex : integer): TJSValue;
procedure SetA(AIndex : integer; const AValue: TJSValue);
Public
- Constructor Create(ALine,ARow : Integer; Const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; Const ASource : String = ''); override;
Destructor Destroy; override;
Property Pattern : TJSValue Read FPattern Write FPattern;
Property PatternFlags : TJSValue Read FPatternFlags Write FPatternFlags;
@@ -213,7 +213,7 @@ Type
FFindex: Integer;
Public
Destructor Destroy; override;
- Property Expr : TJSelement Read FExpr Write FExpr;
+ Property Expr : TJSElement Read FExpr Write FExpr;
Property ElementIndex : Integer Read FFindex Write FFIndex;
end;
@@ -233,7 +233,8 @@ Type
private
FElements: TJSArrayLiteralElements;
Public
- Constructor Create(ALine,ARow : Integer; const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; const ASource : String = ''); override;
+ procedure AddElement(El: TJSElement);
Destructor Destroy; override;
Property Elements : TJSArrayLiteralElements Read FElements;
end;
@@ -266,7 +267,7 @@ Type
private
FElements: TJSObjectLiteralElements;
Public
- Constructor Create(ALine,ARow : Integer; const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; const ASource : String = ''); override;
Destructor Destroy; override;
Property Elements : TJSObjectLiteralElements Read FElements;
end;
@@ -292,6 +293,7 @@ Type
FArgs: TJSArguments;
Public
Destructor Destroy; override;
+ procedure AddArg(El: TJSElement);
Property Args : TJSArguments Read FArgs Write FArgs;
end;
@@ -322,6 +324,7 @@ Type
FExpr: TJSElement;
Public
Destructor Destroy; override;
+ procedure AddArg(El: TJSElement);
Property Expr : TJSElement Read FExpr Write FExpr;
Property Args : TJSArguments Read FArgs Write FArgs;
end;
@@ -345,7 +348,7 @@ Type
TJSVariableStatement = Class(TJSUnary);
- { TJSExpressionStatement - ? }
+ { TJSExpressionStatement - A; }
TJSExpressionStatement = Class(TJSUnary);
@@ -879,7 +882,7 @@ Type
FCond: TJSelement;
FDefault: TJSCaseElement;
Public
- Constructor Create(ALine,ARow : Integer; const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; const ASource : String = ''); override;
Destructor Destroy; override;
Property Cond : TJSelement Read FCond Write FCond;
Property Cases : TJSCaseElements Read FCases;
@@ -967,7 +970,7 @@ Type
FStatements: TJSElementNodes;
FVars: TJSElementNodes;
Public
- Constructor Create(ALine,ARow : Integer; const ASource : String = ''); override;
+ Constructor Create(ALine,AColumn : Integer; const ASource : String = ''); override;
Destructor Destroy; override;
Property Vars : TJSElementNodes Read FVars;
Property Functions : TJSElementNodes Read FFunctions;
@@ -1500,10 +1503,10 @@ end;
{ TJSElement }
-constructor TJSElement.Create(ALine, ARow: Integer; const ASource: String);
+constructor TJSElement.Create(ALine, AColumn: Integer; const ASource: String);
begin
FLine:=ALine;
- FRow:=ARow;
+ FColumn:=AColumn;
FSource:=ASource;
end;
@@ -1520,10 +1523,10 @@ begin
FArgv[AIndex]:=Avalue;
end;
-constructor TJSRegularExpressionLiteral.Create(ALine, ARow: Integer;
+constructor TJSRegularExpressionLiteral.Create(ALine, AColumn: Integer;
const ASource: String);
begin
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
FPattern:=TJSValue.Create;
FPatternFlags:=TJSValue.Create;
end;
@@ -1549,12 +1552,17 @@ end;
{ TJSArrayLiteral }
-constructor TJSArrayLiteral.Create(ALine, ARow: Integer; Const ASource: String = '');
+constructor TJSArrayLiteral.Create(ALine, AColumn: Integer; const ASource: String);
begin
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
FElements:=TJSArrayLiteralElements.Create(TJSArrayLiteralElement);
end;
+procedure TJSArrayLiteral.AddElement(El: TJSElement);
+begin
+ Elements.AddElement.Expr:=El;
+end;
+
destructor TJSArrayLiteral.Destroy;
begin
FreeAndNil(FElements);
@@ -1577,9 +1585,9 @@ end;
{ TJSObjectLiteral }
-constructor TJSObjectLiteral.Create(ALine, ARow: Integer; const ASource: String = '');
+constructor TJSObjectLiteral.Create(ALine, AColumn: Integer; const ASource: String = '');
begin
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
FElements:=TJSObjectLiteralElements.Create(TJSObjectLiteralElement);
end;
@@ -1613,6 +1621,11 @@ begin
inherited Destroy;
end;
+procedure TJSNewMemberExpression.AddArg(El: TJSElement);
+begin
+ Args.Elements.AddElement.Expr:=El;
+end;
+
{ TJSMemberExpression }
destructor TJSMemberExpression.Destroy;
@@ -1630,6 +1643,11 @@ begin
inherited Destroy;
end;
+procedure TJSCallExpression.AddArg(El: TJSElement);
+begin
+ Args.Elements.AddElement.Expr:=El;
+end;
+
{ TJSUnary }
Class function TJSUnary.PrefixOperatorToken: tjsToken;
@@ -1796,9 +1814,9 @@ end;
{ TJSSwitch }
-constructor TJSSwitchStatement.Create(ALine, ARow: Integer; const ASource: String);
+constructor TJSSwitchStatement.Create(ALine, AColumn: Integer; const ASource: String);
begin
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
FCases:=TJSCaseElements.Create(TJSCaseElement);
end;
@@ -1834,10 +1852,10 @@ end;
{ TJSSourceElements }
-constructor TJSSourceElements.Create(ALine, ARow: Integer; const ASource: String
+constructor TJSSourceElements.Create(ALine, AColumn: Integer; const ASource: String
);
begin
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
FStatements:=TJSElementNodes.Create(TJSElementNode);
FFunctions:=TJSElementNodes.Create(TJSElementNode);
FVars:=TJSElementNodes.Create(TJSElementNode);
@@ -1916,10 +1934,10 @@ end;
{ TJSLiteral }
-constructor TJSLiteral.Create(ALine, ARow: Integer; const ASource: String);
+constructor TJSLiteral.Create(ALine, AColumn: Integer; const ASource: String);
begin
FValue:=TJSValue.Create;
- inherited Create(ALine, ARow, ASource);
+ inherited Create(ALine, AColumn, ASource);
end;
destructor TJSLiteral.Destroy;
diff --git a/packages/fcl-js/src/jswriter.pp b/packages/fcl-js/src/jswriter.pp
index a0d5977052..4ea5d9a8c9 100644
--- a/packages/fcl-js/src/jswriter.pp
+++ b/packages/fcl-js/src/jswriter.pp
@@ -23,15 +23,25 @@ uses
SysUtils, jstoken, jsbase, jstree;
Type
+ TTextWriter = class;
+
+ TTextWriterWriting = procedure(Sender: TTextWriter) of object;
{ TTextWriter }
TTextWriter = Class(TObject)
+ private
+ FCurElement: TJSElement;
+ FCurLine: integer;
+ FCurColumn: integer;
+ FOnWriting: TTextWriterWriting;
protected
Function DoWrite(Const S : AnsiString) : Integer; virtual; abstract;
Function DoWrite(Const S : UnicodeString) : Integer; virtual; abstract;
+ Procedure Writing; // called before adding new characters
Public
// All functions return the number of bytes copied to output stream.
+ constructor Create;
Function Write(Const S : UnicodeString) : Integer;
Function Write(Const S : AnsiString) : Integer;
Function WriteLn(Const S : AnsiString) : Integer;
@@ -39,6 +49,10 @@ Type
Function WriteLn(Const Fmt : AnsiString; Args : Array of const) : Integer;
Function Write(Const Args : Array of const) : Integer;
Function WriteLn(Const Args : Array of const) : Integer;
+ Property CurLine: integer read FCurLine write FCurLine;
+ Property CurColumn: integer read FCurColumn write FCurColumn;// char index, not codepoint
+ Property CurElement: TJSElement read FCurElement write FCurElement;
+ Property OnWriting: TTextWriterWriting read FOnWriting write FOnWriting;
end;
{ TFileWriter }
@@ -105,14 +119,14 @@ Type
TJSWriter = Class
private
FCurIndent : Integer;
- FLinePos : Integer;
- FIndentSize: Byte;
+ FFreeWriter : Boolean;
FIndentChar : Char;
+ FIndentSize: Byte;
+ FLinePos : Integer;
FOptions: TWriteOptions;
- FWriter: TTextWriter;
- FFreeWriter : Boolean;
FSkipCurlyBrackets : Boolean;
FSkipRoundBrackets : Boolean;
+ FWriter: TTextWriter;
function GetUseUTF8: Boolean;
procedure SetOptions(AValue: TWriteOptions);
Protected
@@ -254,7 +268,7 @@ begin
MinLen:=Result+FBufPos;
If (MinLen>Capacity) then
begin
- DesLen:=Round(FCapacity*1.25);
+ DesLen:=(FCapacity*5) div 4;
if DesLen>MinLen then
MinLen:=DesLen;
Capacity:=MinLen;
@@ -274,7 +288,7 @@ begin
MinLen:=Result+FBufPos;
If (MinLen>Capacity) then
begin
- DesLen:=Round(FCapacity*1.25);
+ DesLen:=(FCapacity*5) div 4;
if DesLen>MinLen then
MinLen:=DesLen;
Capacity:=MinLen;
@@ -285,6 +299,7 @@ end;
Constructor TBufferWriter.Create(Const ACapacity: Cardinal);
begin
+ inherited Create;
Capacity:=ACapacity;
end;
@@ -673,7 +688,9 @@ begin
if El is TJSPrimaryExpressionThis then
Write('this')
else if El is TJSPrimaryExpressionIdent then
- Write(TJSPrimaryExpressionIdent(El).Name);
+ Write(TJSPrimaryExpressionIdent(El).Name)
+ else
+ Error(SErrUnknownJSClass,[El.ClassName]);
end;
procedure TJSWriter.WriteArrayLiteral(El: TJSArrayLiteral);
@@ -777,6 +794,7 @@ procedure TJSWriter.WriteMemberExpression(El: TJSMemberExpression);
var
MExpr: TJSElement;
+ Args: TJSArguments;
begin
if El is TJSNewMemberExpression then
Write('new ');
@@ -809,8 +827,12 @@ begin
end
else if (El is TJSNewMemberExpression) then
begin
- if (Assigned(TJSNewMemberExpression(El).Args)) then
- WriteArrayLiteral(TJSNewMemberExpression(El).Args)
+ Args:=TJSNewMemberExpression(El).Args;
+ if Assigned(Args) then
+ begin
+ Writer.CurElement:=Args;
+ WriteArrayLiteral(Args);
+ end
else
Write('()');
end;
@@ -821,7 +843,10 @@ procedure TJSWriter.WriteCallExpression(El: TJSCallExpression);
begin
WriteJS(El.Expr);
if Assigned(El.Args) then
- WriteArrayLiteral(El.Args)
+ begin
+ Writer.CurElement:=El.Args;
+ WriteArrayLiteral(El.Args);
+ end
else
Write('()');
end;
@@ -1219,23 +1244,23 @@ Var
TN : TJSString;
begin
- TN:=EL.TargetName;
+ TN:=El.TargetName;
if (El is TJSForStatement) then
WriteForStatement(TJSForStatement(El))
else if (El is TJSSwitchStatement) then
WriteSwitchStatement(TJSSwitchStatement(El))
else if (El is TJSForInStatement) then
WriteForInStatement(TJSForInStatement(El))
- else if EL is TJSWhileStatement then
+ else if El is TJSWhileStatement then
WriteWhileStatement(TJSWhileStatement(El))
- else if (EL is TJSContinueStatement) then
+ else if (El is TJSContinueStatement) then
begin
if (TN<>'') then
Write('continue '+TN)
else
Write('continue');
end
- else if (EL is TJSBreakStatement) then
+ else if (El is TJSBreakStatement) then
begin
if (TN<>'') then
Write('break '+TN)
@@ -1243,7 +1268,7 @@ begin
Write('break');
end
else
- Error('Unknown target statement class: "%s"',[EL.ClassName])
+ Error('Unknown target statement class: "%s"',[El.ClassName])
end;
procedure TJSWriter.WriteReturnStatement(El: TJSReturnStatement);
@@ -1384,6 +1409,8 @@ begin
end;
procedure TJSWriter.WriteJS(El: TJSElement);
+var
+ LastWritingEl: TJSElement;
begin
{$IFDEF DEBUGJSWRITER}
if (EL<>Nil) then
@@ -1391,6 +1418,8 @@ begin
else
system.Writeln('WriteJS : El = Nil');
{$ENDIF}
+ LastWritingEl:=Writer.CurElement;
+ Writer.CurElement:=El;
if (El is TJSEmptyBlockStatement ) then
WriteEmptyBlockStatement(TJSEmptyBlockStatement(El))
else if (El is TJSEmptyStatement) then
@@ -1449,6 +1478,7 @@ begin
Error(SErrUnknownJSClass,[El.ClassName]);
// Write('/* '+El.ClassName+' */');
FSkipCurlyBrackets:=False;
+ Writer.CurElement:=LastWritingEl;
end;
{ TFileWriter }
@@ -1467,6 +1497,7 @@ end;
Constructor TFileWriter.Create(Const AFileNAme: String);
begin
+ inherited Create;
FFileName:=AFileName;
Assign(FFile,AFileName);
Rewrite(FFile);
@@ -1490,33 +1521,103 @@ end;
{ TTextWriter }
-Function TTextWriter.Write(Const S: UnicodeString) : Integer;
+procedure TTextWriter.Writing;
begin
+ if Assigned(OnWriting) then
+ OnWriting(Self);
+end;
+
+constructor TTextWriter.Create;
+begin
+ FCurLine:=1;
+ FCurColumn:=1;
+end;
+
+function TTextWriter.Write(const S: UnicodeString): Integer;
+var
+ p: PWideChar;
+ c: WideChar;
+begin
+ if S='' then exit;
+ Writing;
Result:=DoWrite(S);
+ p:=PWideChar(S);
+ repeat
+ c:=p^;
+ case c of
+ #0:
+ if p-PWideChar(S)=length(S)*2 then
+ break
+ else
+ inc(FCurColumn);
+ #10,#13:
+ begin
+ FCurColumn:=1;
+ inc(FCurLine);
+ inc(p);
+ if (p^ in [#10,#13]) and (c<>p^) then inc(p);
+ continue;
+ end;
+ else
+ // ignore low/high surrogate, CurColumn is char index, not codepoint
+ inc(FCurColumn);
+ end;
+ inc(p);
+ until false;
end;
-Function TTextWriter.Write(Const S: AnsiString) : integer;
+function TTextWriter.Write(const S: AnsiString): Integer;
+var
+ p: PChar;
+ c: Char;
begin
+ if S='' then exit;
+ Writing;
Result:=DoWrite(S);
+ p:=PChar(S);
+ repeat
+ c:=p^;
+ case c of
+ #0:
+ if p-PChar(S)=length(S) then
+ break
+ else
+ inc(FCurColumn);
+ #10,#13:
+ begin
+ FCurColumn:=1;
+ inc(FCurLine);
+ inc(p);
+ if (p^ in [#10,#13]) and (c<>p^) then inc(p);
+ continue;
+ end;
+ else
+ // ignore UTF-8 multibyte chars, CurColumn is char index, not codepoint
+ inc(FCurColumn);
+ end;
+ inc(p);
+ until false;
end;
-Function TTextWriter.WriteLn(Const S: AnsiString) : Integer;
+function TTextWriter.WriteLn(const S: AnsiString): Integer;
begin
- Result:=DoWrite(S)+DoWrite(sLineBreak);
+ Result:=Write(S)+Write(sLineBreak);
end;
-Function TTextWriter.Write(Const Fmt: AnsiString; Args: Array of const) : Integer;
+function TTextWriter.Write(const Fmt: AnsiString;
+ Args: array of const): Integer;
begin
- Result:=DoWrite(Format(Fmt,Args));
+ Result:=Write(Format(Fmt,Args));
end;
-Function TTextWriter.WriteLn(Const Fmt: AnsiString; Args: Array of const) : integer;
+function TTextWriter.WriteLn(const Fmt: AnsiString;
+ Args: array of const): Integer;
begin
Result:=WriteLn(Format(Fmt,Args));
end;
-Function TTextWriter.Write(Const Args: Array of const) : Integer;
+function TTextWriter.Write(const Args: array of const): Integer;
Var
I : Integer;
@@ -1552,11 +1653,11 @@ begin
if (U<>'') then
Result:=Result+Write(u)
else if (S<>'') then
- Result:=Result+write(s);
+ Result:=Result+Write(s);
end;
end;
-Function TTextWriter.WriteLn(Const Args: Array of const) : integer;
+function TTextWriter.WriteLn(const Args: array of const): Integer;
begin
Result:=Write(Args)+Writeln('');
end;
diff --git a/packages/fcl-js/tests/tcsrcmap.pas b/packages/fcl-js/tests/tcsrcmap.pas
new file mode 100644
index 0000000000..65927a9ace
--- /dev/null
+++ b/packages/fcl-js/tests/tcsrcmap.pas
@@ -0,0 +1,175 @@
+unit TCSrcMap;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testregistry, fpjson, JSSrcMap;
+
+type
+
+ { TCustomTestSrcMap }
+
+ TCustomTestSrcMap = class(TTestCase)
+ protected
+ procedure CheckEl(aName: String; El: TJSONData; aClass: TClass);
+ function GetEl(Obj: TJSONObject; aName: String; aClass: TClass): TJSONData;
+ end;
+
+ { TTestSrcMap }
+
+ TTestSrcMap = class(TCustomTestSrcMap)
+ published
+ procedure Test_Base64VLQ;
+ procedure TestSrcMapIgnoreDuplicate;
+ procedure TestSrcMapNames;
+ end;
+
+implementation
+
+{ TCustomTestSrcMap }
+
+procedure TCustomTestSrcMap.CheckEl(aName: String; El: TJSONData; aClass: TClass);
+begin
+ AssertNotNull('json "'+aName+'" exists',El);
+ AssertEquals('json "'+aName+'" class',El.ClassType,aClass);
+end;
+
+function TCustomTestSrcMap.GetEl(Obj: TJSONObject; aName: String; aClass: TClass): TJSONData;
+begin
+ Result:=Obj.Elements[aName];
+ CheckEl(aName,Result,aClass);
+end;
+
+{ TTestSrcMap }
+
+procedure TTestSrcMap.Test_Base64VLQ;
+var
+ i: Integer;
+ s: String;
+ p: PChar;
+ j: NativeInt;
+begin
+ for i:=-511 to 511 do
+ begin
+ s:=EncodeBase64VLQ(i);
+ p:=PChar(s);
+ j:=DecodeBase64VLQ(p);
+ if i<>j then
+ Fail('Encode/DecodeBase64VLQ OrigIndex='+IntToStr(i)+' Code="'+s+'" NewIndex='+IntToStr(j));
+ end;
+end;
+
+procedure TTestSrcMap.TestSrcMapIgnoreDuplicate;
+var
+ sm: TSourceMap;
+ Obj: TJSONObject;
+ El: TJSONData;
+ Arr: TJSONArray;
+begin
+ Obj:=nil;
+ sm:=TSourceMap.Create('generated.js');
+ try
+ sm.AddMapping(1,0,'a.js',1,0);
+ sm.AddMapping(2,0);
+ sm.AddMapping(2,0);
+ sm.AddMapping(3,0,'a.js',2,0);
+
+ //writeln(sm.ToString);
+ {
+ version: 3,
+ file: 'generated.js',
+ sources: ['a.js'],
+ names: [],
+ mappings: 'AAAA;A;AACA'
+ }
+ Obj:=sm.ToJSON;
+
+ // version
+ El:=GetEl(Obj,'version',TJSONIntegerNumber);
+ AssertEquals('json "version" value',El.AsInt64,3);
+
+ // file
+ El:=GetEl(Obj,'file',TJSONString);
+ AssertEquals('json "file" value',El.AsString,'generated.js');
+
+ // sources
+ Arr:=TJSONArray(GetEl(Obj,'sources',TJSONArray));
+ AssertEquals('json "sources".count',Arr.Count,1);
+ El:=Arr[0];
+ CheckEl('sources[0]',El,TJSONString);
+ AssertEquals('json "sources[0]" value',El.AsString,'a.js');
+
+ // names
+ Arr:=TJSONArray(GetEl(Obj,'names',TJSONArray));
+ AssertEquals('json "names".count',Arr.Count,0);
+
+ // mappings
+ El:=GetEl(Obj,'mappings',TJSONString);
+ AssertEquals('json "mappings" value',El.AsString,'AAAA;A;AACA');
+
+ finally
+ Obj.Free;
+ sm.Free;
+ end;
+end;
+
+procedure TTestSrcMap.TestSrcMapNames;
+var
+ sm: TSourceMap;
+ Obj: TJSONObject;
+ El: TJSONData;
+ Arr: TJSONArray;
+begin
+ Obj:=nil;
+ sm:=TSourceMap.Create('generated.js');
+ try
+ sm.AddMapping(1,1,'a.js',2,2,'foo');
+ sm.AddMapping(3,3,'a.js',4,4,'foo');
+ writeln(sm.ToString);
+ {
+ version: 3,
+ file: 'generated.js',
+ sources: ['a.js'],
+ names: ['foo'],
+ mappings: 'CACEA;;GAEEA'
+ }
+ Obj:=sm.ToJSON;
+
+ // version
+ El:=GetEl(Obj,'version',TJSONIntegerNumber);
+ AssertEquals('json "version" value',El.AsInt64,3);
+
+ // file
+ El:=GetEl(Obj,'file',TJSONString);
+ AssertEquals('json "file" value',El.AsString,'generated.js');
+
+ // sources
+ Arr:=TJSONArray(GetEl(Obj,'sources',TJSONArray));
+ AssertEquals('json "sources".count',Arr.Count,1);
+ El:=Arr[0];
+ CheckEl('sources[0]',El,TJSONString);
+ AssertEquals('json "sources[0]" value',El.AsString,'a.js');
+
+ // names
+ Arr:=TJSONArray(GetEl(Obj,'names',TJSONArray));
+ AssertEquals('json "names".count',Arr.Count,1);
+ El:=Arr[0];
+ CheckEl('names[0]',El,TJSONString);
+ AssertEquals('json "names[0]" value',El.AsString,'foo');
+
+ // mappings
+ El:=GetEl(Obj,'mappings',TJSONString);
+ AssertEquals('json "mappings" value',El.AsString,'CACEA;;GAEEA');
+
+ finally
+ Obj.Free;
+ sm.Free;
+ end;
+end;
+
+initialization
+ RegisterTests([TTestSrcMap]);
+end.
+
diff --git a/packages/fcl-js/tests/testjs.lpi b/packages/fcl-js/tests/testjs.lpi
index 8f5b6bda2b..74764e0bb0 100644
--- a/packages/fcl-js/tests/testjs.lpi
+++ b/packages/fcl-js/tests/testjs.lpi
@@ -1,32 +1,21 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
- <Version Value="9"/>
+ <Version Value="10"/>
<General>
+ <SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
- <UseXPManifest Value="True"/>
- <Icon Value="0"/>
- <ActiveWindowIndexAtStart Value="0"/>
+ <UseAppBundle Value="False"/>
</General>
- <VersionInfo>
- <Language Value=""/>
- <CharSet Value=""/>
- <StringTable ProductVersion=""/>
- </VersionInfo>
<BuildModes Count="1">
<Item1 Name="default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
- <IgnoreBinaries Value="False"/>
- <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
- <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
- <CommandLineParams Value="--suite=TTestStatementWriter"/>
- <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
@@ -34,260 +23,84 @@
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
- <Units Count="16">
+ <Units Count="13">
<Unit0>
<Filename Value="testjs.lpr"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="testjs"/>
- <WindowIndex Value="1"/>
- <TopLine Value="1"/>
- <CursorPos X="48" Y="3"/>
- <UsageCount Value="201"/>
</Unit0>
<Unit1>
<Filename Value="tcscanner.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="tcscanner"/>
- <WindowIndex Value="1"/>
- <TopLine Value="1"/>
- <CursorPos X="17" Y="22"/>
- <UsageCount Value="201"/>
</Unit1>
<Unit2>
<Filename Value="../src/jsbase.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="jsbase"/>
- <WindowIndex Value="1"/>
- <TopLine Value="1"/>
- <CursorPos X="1" Y="12"/>
- <UsageCount Value="200"/>
</Unit2>
<Unit3>
<Filename Value="../src/jsparser.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="jsparser"/>
- <EditorIndex Value="3"/>
- <WindowIndex Value="1"/>
- <TopLine Value="67"/>
- <CursorPos X="14" Y="85"/>
- <UsageCount Value="201"/>
- <Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="../src/jsscanner.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="JSScanner"/>
- <EditorIndex Value="6"/>
- <WindowIndex Value="1"/>
- <TopLine Value="342"/>
- <CursorPos X="76" Y="345"/>
- <UsageCount Value="201"/>
- <Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="../src/jstree.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="jstree"/>
- <EditorIndex Value="5"/>
- <WindowIndex Value="1"/>
- <TopLine Value="739"/>
- <CursorPos X="3" Y="757"/>
- <UsageCount Value="200"/>
- <Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="tcparser.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="tcparser"/>
- <EditorIndex Value="4"/>
- <WindowIndex Value="1"/>
- <TopLine Value="1878"/>
- <CursorPos X="3" Y="1883"/>
- <UsageCount Value="201"/>
- <Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="../src/jswriter.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="jswriter"/>
- <EditorIndex Value="0"/>
- <WindowIndex Value="1"/>
- <TopLine Value="8"/>
- <CursorPos X="28" Y="15"/>
- <UsageCount Value="202"/>
- <Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="tctextwriter.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="tctextwriter"/>
- <WindowIndex Value="1"/>
- <TopLine Value="4"/>
- <CursorPos X="15" Y="22"/>
- <UsageCount Value="201"/>
</Unit8>
<Unit9>
- <Filename Value="../../../../../projects/lazarus/components/fpcunit/console/consoletestrunner.pas"/>
- <UnitName Value="consoletestrunner"/>
- <WindowIndex Value="1"/>
- <TopLine Value="157"/>
- <CursorPos X="1" Y="175"/>
- <UsageCount Value="4"/>
+ <Filename Value="tcwriter.pp"/>
+ <IsPartOfProject Value="True"/>
</Unit9>
<Unit10>
- <Filename Value="tcwriter.pp"/>
+ <Filename Value="../src/jstoken.pp"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="tcwriter"/>
- <IsVisibleTab Value="True"/>
- <EditorIndex Value="2"/>
- <WindowIndex Value="1"/>
- <TopLine Value="668"/>
- <CursorPos X="45" Y="698"/>
- <UsageCount Value="220"/>
- <Loaded Value="True"/>
</Unit10>
<Unit11>
- <Filename Value="../../../../released/packages/fcl-json/src/fpjson.pp"/>
- <UnitName Value="fpjson"/>
- <WindowIndex Value="1"/>
- <TopLine Value="558"/>
- <CursorPos X="21" Y="580"/>
- <UsageCount Value="61"/>
+ <Filename Value="tcsrcmap.pas"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="TCSrcMap"/>
</Unit11>
<Unit12>
- <Filename Value="../src/jstoken.pp"/>
+ <Filename Value="../src/jssrcmap.pas"/>
<IsPartOfProject Value="True"/>
- <UnitName Value="jstoken"/>
- <EditorIndex Value="1"/>
- <WindowIndex Value="1"/>
- <TopLine Value="1"/>
- <CursorPos X="18" Y="8"/>
- <UsageCount Value="200"/>
- <Loaded Value="True"/>
+ <UnitName Value="JSSrcMap"/>
</Unit12>
- <Unit13>
- <Filename Value="../../../../released/packages/fcl-fpcunit/src/testregistry.pp"/>
- <UnitName Value="testregistry"/>
- <WindowIndex Value="1"/>
- <TopLine Value="106"/>
- <CursorPos X="22" Y="108"/>
- <UsageCount Value="13"/>
- </Unit13>
- <Unit14>
- <Filename Value="../../../rtl/tests/punit.pp"/>
- <UnitName Value="punit"/>
- <WindowIndex Value="1"/>
- <TopLine Value="405"/>
- <CursorPos X="41" Y="415"/>
- <UsageCount Value="18"/>
- </Unit14>
- <Unit15>
- <Filename Value="../../../../released/rtl/inc/mathh.inc"/>
- <WindowIndex Value="1"/>
- <TopLine Value="60"/>
- <CursorPos X="14" Y="78"/>
- <UsageCount Value="13"/>
- </Unit15>
</Units>
- <JumpHistory Count="6" HistoryIndex="5">
- <Position1>
- <Filename Value="tcparser.pp"/>
- <Caret Line="1" Column="1" TopLine="1"/>
- </Position1>
- <Position2>
- <Filename Value="tcparser.pp"/>
- <Caret Line="1732" Column="55" TopLine="1713"/>
- </Position2>
- <Position3>
- <Filename Value="tcparser.pp"/>
- <Caret Line="1883" Column="3" TopLine="1878"/>
- </Position3>
- <Position4>
- <Filename Value="tcwriter.pp"/>
- <Caret Line="66" Column="43" TopLine="51"/>
- </Position4>
- <Position5>
- <Filename Value="tcwriter.pp"/>
- <Caret Line="76" Column="43" TopLine="48"/>
- </Position5>
- <Position6>
- <Filename Value="tcwriter.pp"/>
- <Caret Line="251" Column="31" TopLine="232"/>
- </Position6>
- </JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
- <OtherUnitFiles Value="/home/michael/source/fcl-js/;..;../src"/>
+ <OtherUnitFiles Value="../src"/>
</SearchPaths>
<CodeGeneration>
+ <Checks>
+ <IOChecks Value="True"/>
+ <RangeChecks Value="True"/>
+ <OverflowChecks Value="True"/>
+ <StackChecks Value="True"/>
+ </Checks>
+ <VerifyObjMethodCallValidity Value="True"/>
<Optimizations>
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration>
- <Linking>
- <Debugging>
- <UseHeaptrc Value="True"/>
- </Debugging>
- </Linking>
- <Other>
- <CompilerPath Value="$(CompPath)"/>
- </Other>
</CompilerOptions>
<Debugging>
- <BreakPoints Count="7">
- <Item1>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsGlobal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="../jsscanner.pp"/>
- <Line Value="717"/>
- </Item1>
- <Item2>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="tcparser.pp"/>
- <Line Value="2086"/>
- </Item2>
- <Item3>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="tcparser.pp"/>
- <Line Value="2566"/>
- </Item3>
- <Item4>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="../src/jsparser.pp"/>
- <Line Value="845"/>
- </Item4>
- <Item5>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="../src/jsparser.pp"/>
- <Line Value="754"/>
- </Item5>
- <Item6>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="../src/jsparser.pp"/>
- <Line Value="1287"/>
- </Item6>
- <Item7>
- <Kind Value="bpkSource"/>
- <WatchScope Value="wpsLocal"/>
- <WatchKind Value="wpkWrite"/>
- <Source Value="tcparser.pp"/>
- <Line Value="2253"/>
- </Item7>
- </BreakPoints>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
@@ -300,5 +113,4 @@
</Item3>
</Exceptions>
</Debugging>
- <EditorMacros Count="0"/>
</CONFIG>
diff --git a/packages/fcl-js/tests/testjs.lpr b/packages/fcl-js/tests/testjs.lpr
index badb5ab1e6..574e4a3ff8 100644
--- a/packages/fcl-js/tests/testjs.lpr
+++ b/packages/fcl-js/tests/testjs.lpr
@@ -7,7 +7,7 @@ uses
cwstring,
{$ENDIF}
Classes, consoletestrunner, tcscanner, jsparser, jsscanner, jstree, jsbase,
- tcparser, jswriter, tcwriter, jstoken;
+ tcparser, jswriter, tcwriter, jstoken, JSSrcMap, TCSrcMap;
var
Application: TTestRunner;
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index f8bf81d7ae..2a59133fe7 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -50,7 +50,7 @@ Works:
- chr(integer) -> String.fromCharCode(integer)
- string
- literals
- - setlength(s,newlen) -> s.length == newlen
+ - setlength(s,newlen) -> s = rtl.strSetLength(s,newlen)
- read and write char aString[]
- allow only String, no ShortString, AnsiString, UnicodeString,...
- allow type casting string to external class name 'String'
@@ -309,7 +309,7 @@ Not in Version 1.0:
-O1 insert unit vars for complex literals
-O1 no function Result var when assigned only once
- SetLength(scope.a,l) -> read scope only once, same for
- Include, Exclude, Inc, Dec
+ Include, Exclude, Inc, Dec, +=, -=, *=, /=
-O1 replace constant expression with result
-O1 pass array element by ref: when index is constant, use that directly
- objects, interfaces, advanced records
@@ -440,6 +440,7 @@ type
pbifnSet_SymDiffSet,
pbifnSet_Union,
pbifnSpaceLeft,
+ pbifnStringSetLength,
pbifnUnitInit,
pbivnExceptObject,
pbivnImplementation,
@@ -536,6 +537,7 @@ const
'symDiffSet', // rtl.symDiffSet >< (symmetrical difference)
'unionSet', // rtl.unionSet +
'spaceLeft', // rtl.spaceLeft
+ 'strSetLength',
'$init',
'$e',
'$impl',
@@ -1128,6 +1130,7 @@ type
Function CreateBuiltInIdentifierExpr(AName: string): TJSPrimaryExpressionIdent;
Function CreateSubDeclNameExpr(El: TPasElement; const Name: string;
AContext: TConvertContext): TJSPrimaryExpressionIdent;
+ Function CreateIdentifierExpr(El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent;
Function CreateIdentifierExpr(AName: string; El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent;
Function CreateSwitchStatement(El: TPasImplCaseOf; AContext: TConvertContext): TJSElement;
Function CreateTypeDecl(El: TPasType; AContext: TConvertContext): TJSElement;
@@ -3424,13 +3427,13 @@ Var
OuterSrc , Src: TJSSourceElements;
RegModuleCall: TJSCallExpression;
ArgArray: TJSArguments;
- UsesList: TFPList;
FunDecl, ImplFunc: TJSFunctionDeclarationStatement;
UsesSection: TPasSection;
ModuleName, ModVarName: String;
IntfContext: TSectionContext;
ImplVarSt: TJSVariableStatement;
HasImplUsesList: Boolean;
+ UsesList: TFPList;
begin
Result:=Nil;
OuterSrc:=TJSSourceElements(CreateElement(TJSSourceElements, El));
@@ -4282,12 +4285,20 @@ begin
Result:=CreateDotExpression(El,Left,Right);
end;
-function TPasToJSConverter.CreateIdentifierExpr(AName: string; El: TPasElement;
+function TPasToJSConverter.CreateIdentifierExpr(El: TPasElement;
AContext: TConvertContext): TJSPrimaryExpressionIdent;
+var
+ I: TJSPrimaryExpressionIdent;
+begin
+ I:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El));
+ I.Name:=TJSString(TransformVariableName(El,AContext));
+ Result:=I;
+end;
+function TPasToJSConverter.CreateIdentifierExpr(AName: string; El: TPasElement;
+ AContext: TConvertContext): TJSPrimaryExpressionIdent;
Var
I : TJSPrimaryExpressionIdent;
-
begin
I:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El));
AName:=TransformVariableName(El,AName,AContext);
@@ -5895,8 +5906,7 @@ var
ResolvedParam0: TPasResolverResult;
ArrayType: TPasArrayType;
Call: TJSCallExpression;
- ValInit, Arg: TJSElement;
- AssignSt: TJSSimpleAssignStatement;
+ ValInit: TJSElement;
AssignContext: TAssignContext;
ElType: TPasType;
begin
@@ -5948,21 +5958,26 @@ begin
end
else if ResolvedParam0.BaseType=btString then
begin
- // convert "SetLength(string,NewLen);" to "string.length == NewLen;"
+ // convert "SetLength(astring,NewLen);" to "astring = rtl.strSetLength(astring,NewLen);"
{$IFDEF VerbosePasResolver}
writeln('TPasToJSConverter.ConvertBuiltInSetLength string');
{$ENDIF}
- AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
+ AssignContext:=TAssignContext.Create(El,nil,AContext);
try
- Arg:=ConvertElement(Param0,AContext);
- // left side: string.length
- AssignSt.LHS:=CreateDotExpression(El,Arg,CreateBuiltInIdentifierExpr('length'));
- // right side: newlength
- AssignSt.Expr:=ConvertElement(El.Params[1],AContext);
- Result:=AssignSt;
+ AContext.Resolver.ComputeElement(Param0,AssignContext.LeftResolved,[rcNoImplicitProc]);
+ AssignContext.RightResolved:=AssignContext.LeftResolved;
+
+ // create right side rtl.strSetLength(aString,NewLen)
+ Call:=CreateCallExpression(El);
+ AssignContext.RightSide:=Call;
+ Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnStringSetLength]]);
+ Call.AddArg(ConvertElement(Param0,AContext));
+ Call.AddArg(ConvertElement(El.Params[1],AContext));
+
+ Result:=CreateAssignStatement(Param0,AssignContext);
finally
- if Result=nil then
- AssignSt.Free;
+ AssignContext.RightSide.Free;
+ AssignContext.Free;
end;
end
else
@@ -6046,21 +6061,96 @@ end;
function TPasToJSConverter.ConvertBuiltIn_IncDec(El: TParamsExpr;
AContext: TConvertContext): TJSElement;
-// convert inc(a,b) to a+=b
-// convert dec(a,b) to a-=b
+{ inc(a) or inc(a,b)
+ if a is a variable:
+ convert inc(a,b) to a+=b
+ if a is a var/out arg:
+ convert inc(a,b) to a.set(a.get+b)
+ if a is a property
+ Getter: field, procedure
+ if a is an indexed-property
+ Getter: field, procedure
+ if a is a property with index-specifier
+ Getter: field, procedure
+}
var
AssignSt: TJSAssignStatement;
+ Expr: TPasExpr;
+ ExprResolved: TPasResolverResult;
+ ExprArg: TPasArgument;
+ ValueJS: TJSElement;
+ Call: TJSCallExpression;
+ IsInc: Boolean;
+ AddJS: TJSAdditiveExpression;
begin
- if CompareText((El.Value as TPrimitiveExpr).Value,'inc')=0 then
- AssignSt:=TJSAddEqAssignStatement(CreateElement(TJSAddEqAssignStatement,El))
- else
- AssignSt:=TJSSubEqAssignStatement(CreateElement(TJSSubEqAssignStatement,El));
- Result:=AssignSt;
- AssignSt.LHS:=ConvertExpression(El.Params[0],AContext);
+ Result:=nil;
+ IsInc:=CompareText((El.Value as TPrimitiveExpr).Value,'inc')=0;
+ Expr:=El.Params[0];
+ AContext.Resolver.ComputeElement(Expr,ExprResolved,[]);
+
+ // convert value
if length(El.Params)=1 then
- AssignSt.Expr:=CreateLiteralNumber(El,1)
+ ValueJS:=CreateLiteralNumber(El,1)
else
- AssignSt.Expr:=ConvertExpression(El.Params[1],AContext);
+ ValueJS:=ConvertExpression(El.Params[1],AContext);
+
+ // check target variable
+ AssignSt:=nil;
+ Call:=nil;
+ try
+ if ExprResolved.IdentEl is TPasArgument then
+ begin
+ ExprArg:=TPasArgument(ExprResolved.IdentEl);
+ if ExprArg.Access in [argVar,argOut] then
+ begin
+ // target variable is a reference
+ // -> convert inc(ref,b) to ref.set(ref.get()+b)
+ Call:=CreateCallExpression(El);
+ // create "ref.set"
+ Call.Expr:=CreateDotExpression(El,
+ CreateIdentifierExpr(ExprResolved.IdentEl,AContext),
+ CreateBuiltInIdentifierExpr(TempRefObjSetterName));
+ // create "+"
+ if IsInc then
+ AddJS:=TJSAdditiveExpressionPlus(CreateElement(TJSAdditiveExpressionPlus,El))
+ else
+ AddJS:=TJSAdditiveExpressionMinus(CreateElement(TJSAdditiveExpressionMinus,El));
+ Call.AddArg(AddJS);
+ // create "ref.get()"
+ AddJS.A:=TJSCallExpression(CreateElement(TJSCallExpression,El));
+ TJSCallExpression(AddJS.A).Expr:=CreateDotExpression(El,
+ CreateIdentifierExpr(ExprResolved.IdentEl,AContext),
+ CreateBuiltInIdentifierExpr(TempRefObjGetterName));
+ // add "b"
+ AddJS.B:=ValueJS;
+ ValueJS:=nil;
+
+ Result:=Call;
+ exit;
+ end;
+ end
+ else if ExprResolved.IdentEl is TPasProperty then
+ begin
+ RaiseNotSupported(Expr,AContext,20170501151316);
+ end;
+
+ // convert inc(avar,b) to a+=b
+ if IsInc then
+ AssignSt:=TJSAddEqAssignStatement(CreateElement(TJSAddEqAssignStatement,El))
+ else
+ AssignSt:=TJSSubEqAssignStatement(CreateElement(TJSSubEqAssignStatement,El));
+ AssignSt.LHS:=ConvertExpression(El.Params[0],AContext);
+ AssignSt.Expr:=ValueJS;
+ ValueJS:=nil;
+ Result:=AssignSt;
+ finally
+ ValueJS.Free;
+ if Result=nil then
+ begin
+ AssignSt.Free;
+ Call.Free;
+ end;
+ end;
end;
function TPasToJSConverter.ConvertBuiltIn_Assigned(El: TParamsExpr;
diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas
index e52e518f56..13896fbfd0 100644
--- a/packages/pastojs/tests/tcmodules.pas
+++ b/packages/pastojs/tests/tcmodules.pas
@@ -292,6 +292,7 @@ type
Procedure TestArrayElement_AsParams;
Procedure TestArrayElementFromFuncResult_AsParams;
Procedure TestArrayEnumTypeRange;
+ Procedure TestArray_SetLengthOutArg;
Procedure TestArray_SetLengthProperty;
Procedure TestArray_OpenArrayOfString;
Procedure TestArray_Concat;
@@ -357,6 +358,7 @@ type
Procedure TestClass_NestedSelf;
Procedure TestClass_NestedClassSelf;
Procedure TestClass_NestedCallInherited;
+ Procedure TestClass_TObjectFree; // ToDO
// class of
Procedure TestClassOf_Create;
@@ -1680,16 +1682,27 @@ end;
procedure TTestModule.TestIncDec;
begin
StartProgram(false);
- Add('var');
- Add(' Bar: longint;');
- Add('begin');
- Add(' inc(bar);');
- Add(' inc(bar,2);');
- Add(' dec(bar);');
- Add(' dec(bar,3);');
+ Add([
+ 'procedure DoIt(var i: longint);',
+ 'begin',
+ ' inc(i);',
+ ' inc(i,2);',
+ 'end;',
+ 'var',
+ ' Bar: longint;',
+ 'begin',
+ ' inc(bar);',
+ ' inc(bar,2);',
+ ' dec(bar);',
+ ' dec(bar,3);',
+ '']);
ConvertProgram;
CheckSource('TestIncDec',
LinesToStr([ // statements
+ 'this.DoIt = function (i) {',
+ ' i.set(i.get()+1);',
+ ' i.set(i.get()+2);',
+ '};',
'this.Bar = 0;'
]),
LinesToStr([ // this.$main
@@ -2237,11 +2250,8 @@ begin
Add(' now();');
Add(' uNit2.now;');
Add(' uNit2.now();');
- Add(' test1.now;');
- Add(' test1.now();');
Add(' doit;');
Add(' uNit2.doit;');
- Add(' test1.doit;');
ConvertUnit;
CheckSource('TestProcedureExternalOtherUnit',
LinesToStr([
@@ -2251,12 +2261,9 @@ begin
'Date.now();',
'Date.now();',
'Date.now();',
- 'Date.now();',
- 'Date.now();',
'pas.unit2.DoIt();',
'pas.unit2.DoIt();',
- 'pas.unit2.DoIt();'
- ]));
+ '']));
end;
procedure TTestModule.TestProc_Asm;
@@ -3573,10 +3580,10 @@ begin
Add('begin');
Add(' d:=nan;');
Add(' d:=uNit2.nan;');
- Add(' d:=test1.nan;');
+ Add(' d:=test1.d;');
Add(' i:=iv;');
Add(' i:=uNit2.iv;');
- Add(' i:=test1.iv;');
+ Add(' i:=test1.i;');
ConvertUnit;
CheckSource('TestVarExternalOtherUnit',
LinesToStr([
@@ -3585,10 +3592,10 @@ begin
LinesToStr([ // this.$init
'$impl.d = Global.NaN;',
'$impl.d = Global.NaN;',
- '$impl.d = Global.NaN;',
- '$i = pas.unit2.iV;',
+ '$impl.d = $impl.d;',
'$i = pas.unit2.iV;',
'$i = pas.unit2.iV;',
+ '$i = $i;',
'']),
LinesToStr([ // implementation
'$impl.d = 0.0;',
@@ -3843,16 +3850,25 @@ end;
procedure TTestModule.TestString_SetLength;
begin
StartProgram(false);
- Add('var s: string;');
- Add('begin');
- Add(' SetLength(s,3);');
+ Add([
+ 'procedure DoIt(var s: string);',
+ 'begin',
+ ' SetLength(s,2);',
+ 'end;',
+ 'var s: string;',
+ 'begin',
+ ' SetLength(s,3);',
+ '']);
ConvertProgram;
CheckSource('TestString_SetLength',
LinesToStr([ // statements
- 'this.s = "";'
- ]),
+ 'this.DoIt = function (s) {',
+ ' s.set(rtl.strSetLength(s.get(), 2));',
+ '};',
+ 'this.s = "";',
+ '']),
LinesToStr([ // this.$main
- '$mod.s.length = 3;'
+ '$mod.s = rtl.strSetLength($mod.s, 3);'
]));
end;
@@ -4940,6 +4956,28 @@ begin
'']));
end;
+procedure TTestModule.TestArray_SetLengthOutArg;
+begin
+ StartProgram(false);
+ Add([
+ 'type TArrInt = array of longint;',
+ 'procedure DoIt(out a: TArrInt);',
+ 'begin',
+ ' SetLength(a,2);',
+ 'end;',
+ 'begin',
+ '']);
+ ConvertProgram;
+ CheckSource('TestArray_SetLengthOutArg',
+ LinesToStr([ // statements
+ 'this.DoIt = function (a) {',
+ ' a.set(rtl.arraySetLength(a.get(), 2, 0));',
+ '};',
+ '']),
+ LinesToStr([
+ '']));
+end;
+
procedure TTestModule.TestArray_SetLengthProperty;
begin
StartProgram(false);
@@ -8026,6 +8064,59 @@ begin
'']));
end;
+procedure TTestModule.TestClass_TObjectFree;
+begin
+ exit;
+
+ StartProgram(false);
+ Add([
+ 'type',
+ ' TObject = class',
+ ' Obj: tobject;',
+ ' procedure Free;',
+ ' end;',
+ 'procedure tobject.free;',
+ 'begin',
+ 'end;',
+ 'function DoIt(o: tobject): tobject;',
+ 'var l: tobject;',
+ 'begin',
+ ' o.free;',
+ ' o.free();',
+ ' l.free;',
+ ' o.obj.free;',
+ ' o.obj.free();',
+ ' result.Free;',
+ ' result.Free();',
+ 'end;',
+ 'var o: tobject;',
+ 'begin',
+ ' o.free;',
+ ' o.obj.free;',
+ '']);
+ ConvertProgram;
+ CheckSource('TestClass_NestedCallInherited',
+ LinesToStr([ // statements
+ 'rtl.createClass($mod, "TObject", null, function () {',
+ ' this.$init = function () {',
+ ' this.Obj = null;',
+ ' };',
+ ' this.$final = function () {',
+ ' };',
+ ' this.Free = function () {',
+ ' };',
+ '});',
+ 'this.DoIt = function (o) {',
+ ' var Result = null;',
+ ' var l = null;',
+ ' return Result;',
+ '};',
+ 'this.o = null;',
+ '']),
+ LinesToStr([ // $mod.$main
+ '']));
+end;
+
procedure TTestModule.TestClassOf_Create;
begin
StartProgram(false);
diff --git a/packages/pastojs/tests/tcoptimizations.pas b/packages/pastojs/tests/tcoptimizations.pas
index f11b5c56c5..2bc225c5ed 100644
--- a/packages/pastojs/tests/tcoptimizations.pas
+++ b/packages/pastojs/tests/tcoptimizations.pas
@@ -24,7 +24,7 @@ unit tcoptimizations;
interface
uses
- Classes, SysUtils, fpcunit, testregistry, fppas2js, pastree,
+ Classes, SysUtils, testregistry, fppas2js, pastree,
PScanner, PasUseAnalyzer, PasResolver,
tcmodules;