diff options
author | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2017-06-19 08:47:41 +0000 |
---|---|---|
committer | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2017-06-19 08:47:41 +0000 |
commit | 0dde2d08a8bd20fb8b0468e53ef0eb6225b596b3 (patch) | |
tree | c7b6deaf40c9694b45752e7d443a5955618ccbe3 | |
parent | 2f14bc3dc55f260a0303f59a36175066ef0aeac0 (diff) | |
download | fpc-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.pas | 621 | ||||
-rw-r--r-- | packages/fcl-js/src/jstree.pp | 68 | ||||
-rw-r--r-- | packages/fcl-js/src/jswriter.pp | 151 | ||||
-rw-r--r-- | packages/fcl-js/tests/tcsrcmap.pas | 175 | ||||
-rw-r--r-- | packages/fcl-js/tests/testjs.lpi | 228 | ||||
-rw-r--r-- | packages/fcl-js/tests/testjs.lpr | 2 | ||||
-rw-r--r-- | packages/pastojs/src/fppas2js.pp | 144 | ||||
-rw-r--r-- | packages/pastojs/tests/tcmodules.pas | 139 | ||||
-rw-r--r-- | packages/pastojs/tests/tcoptimizations.pas | 2 |
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; |