paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-13 23:26:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronised with trunk till r40466

Browse Source 
git-svn-id: branches/debug_eh@40467 -
This commit is contained in:
Jonas Maebe 2018-12-04 19:54:31 +00:00
commit 9630eb7ce9
47 changed files with 2612 additions and 1379 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -6994,16 +6994,21 @@ packages/pastojs/src/fppas2js.pp svneol=native#text/plain
packages/pastojs/src/fppjssrcmap.pp svneol=native#text/plain
packages/pastojs/src/pas2js_defines.inc svneol=native#text/plain
packages/pastojs/src/pas2jscompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jscompilercfg.pp svneol=native#text/plain
packages/pastojs/src/pas2jscompilerpp.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfilecache.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfileutils.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilsnodejs.inc svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilsunix.inc svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilswin.inc svneol=native#text/plain
packages/pastojs/src/pas2jsfs.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfscompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jslogger.pp svneol=native#text/plain
packages/pastojs/src/pas2jspcucompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jspparser.pp svneol=native#text/plain
packages/pastojs/src/pas2jsutils.pp svneol=native#text/plain
packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
packages/pastojs/tests/tcfiler.pas svneol=native#text/plain
packages/pastojs/tests/tcmodules.pas svneol=native#text/plain
@ -9605,6 +9610,7 @@ rtl/linux/aarch64/stat.inc svneol=native#text/plain
rtl/linux/aarch64/syscall.inc svneol=native#text/plain
rtl/linux/aarch64/syscallh.inc svneol=native#text/plain
rtl/linux/aarch64/sysnr.inc svneol=native#text/plain
rtl/linux/arm/abitag.inc svneol=native#text/plain
rtl/linux/arm/bsyscall.inc svneol=native#text/plain
rtl/linux/arm/cprt0.as svneol=native#text/plain
rtl/linux/arm/dllprt0.as svneol=native#text/plain
@ -9626,6 +9632,7 @@ rtl/linux/errno.inc svneol=native#text/plain
rtl/linux/errnostr.inc svneol=native#text/plain
rtl/linux/fpcylix.pp svneol=native#text/plain
rtl/linux/fpmake.inc svneol=native#text/plain
rtl/linux/i386/abitag.inc svneol=native#text/plain
rtl/linux/i386/bsyscall.inc svneol=native#text/plain
rtl/linux/i386/si_c.inc svneol=native#text/plain
rtl/linux/i386/si_c21.inc svneol=native#text/plain

5
compiler/aoptobj.pas
View File

@ -1059,7 +1059,10 @@ Unit AoptObj;
Top_Reg :
OpsEqual:=o1.reg=o2.reg;
Top_Ref :
OpsEqual := references_equal(o1.ref^, o2.ref^);
OpsEqual:=
references_equal(o1.ref^, o2.ref^) and
(o1.ref^.volatility=[]) and
(o2.ref^.volatility=[]);
Top_Const :
OpsEqual:=o1.val=o2.val;
Top_None :

4
compiler/arm/aoptcpu.pas
View File

@ -117,7 +117,9 @@ Implementation
(r1.signindex = r2.signindex) and
(r1.shiftimm = r2.shiftimm) and
(r1.addressmode = r2.addressmode) and
(r1.shiftmode = r2.shiftmode);
(r1.shiftmode = r2.shiftmode) and
(r1.volatility=[]) and
(r2.volatility=[]);
end;
function MatchInstruction(const instr: tai; const op: TCommonAsmOps; const cond: TAsmConds; const postfix: TOpPostfixes): boolean;

4
compiler/avr/aoptcpu.pas
View File

@ -75,7 +75,9 @@ Implementation
(r1.index = r2.index) and (r1.scalefactor = r2.scalefactor) and
(r1.symbol=r2.symbol) and (r1.refaddr = r2.refaddr) and
(r1.relsymbol = r2.relsymbol) and
(r1.addressmode = r2.addressmode);
(r1.addressmode = r2.addressmode) and
(r1.volatility=[]) and
(r2.volatility=[]);
end;

1
compiler/compinnr.pas
View File

@ -117,6 +117,7 @@ type
in_not_assign_x = 95,
in_gettypekind_x = 96,
in_faraddr_x = 97,
in_volatile_x = 98,
{ Internal constant functions }
in_const_sqr = 100,

2
compiler/globtype.pas
View File

@ -392,7 +392,7 @@ interface
{ switches being applied to all CPUs at the given level }
genericlevel1optimizerswitches = [cs_opt_level1,cs_opt_peephole];
genericlevel2optimizerswitches = [cs_opt_level2,cs_opt_remove_emtpy_proc];
genericlevel3optimizerswitches = [cs_opt_level3,cs_opt_constant_propagate,cs_opt_nodedfa,cs_opt_use_load_modify_store,cs_opt_loopunroll];
genericlevel3optimizerswitches = [cs_opt_level3,cs_opt_constant_propagate,cs_opt_nodedfa{$ifndef llvm},cs_opt_use_load_modify_store{$endif},cs_opt_loopunroll];
genericlevel4optimizerswitches = [cs_opt_level4,cs_opt_reorder_fields,cs_opt_dead_values,cs_opt_fastmath];
{ whole program optimizations whose information generation requires

5
compiler/llvm/nllvmmat.pas
View File

@ -34,6 +34,9 @@ type
procedure pass_generate_code; override;
end;
tllvmshlshrnode = class(tcgshlshrnode)
end;
Tllvmunaryminusnode = class(tcgunaryminusnode)
procedure emit_float_sign_change(r: tregister; _size : tdef);override;
end;
@ -154,9 +157,7 @@ end;
begin
cmoddivnode := tllvmmoddivnode;
(*
cshlshrnode := tllvmshlshrnode;
*)
cnotnode := tllvmnotnode;
cunaryminusnode := Tllvmunaryminusnode;
end.

4
compiler/m68k/aoptcpu.pas
View File

@ -65,7 +65,9 @@ unit aoptcpu;
(r1.base = r2.base) and
(r1.index = r2.index) and (r1.scalefactor = r2.scalefactor) and
(r1.symbol=r2.symbol) and (r1.refaddr = r2.refaddr) and
(r1.relsymbol = r2.relsymbol);
(r1.relsymbol = r2.relsymbol) and
(r1.volatility=[]) and
(r2.volatility=[]);
end;
function MatchOperand(const oper1: TOper; const oper2: TOper): boolean;

16
compiler/m68k/n68kinl.pas
View File

@ -26,7 +26,7 @@ unit n68kinl;
interface
uses
node,ninl,ncginl,cpubase;
node,ninl,ncginl,symtype,cpubase;
type
t68kinlinenode = class(tcgInlineNode)
@ -51,6 +51,8 @@ interface
procedure second_frac_real; override;
{procedure second_prefetch; override;
procedure second_abs_long; override;}
protected
function second_incdec_tempregdef: tdef; override;
private
procedure second_do_operation(op: TAsmOp);
end;
@ -342,6 +344,18 @@ implementation
eor.l d1,d2
sub.l d1,d2
}
function t68kinlinenode.second_incdec_tempregdef: tdef;
begin
{ this kludge results in the increment/decrement value of inc/dec to be loaded
always in a datareg, regardless of the target type. This results in significantly
better code on m68k, where if the inc/decrement is loaded to an address register
for pointers, the compiler will generate a bunch of useless data<->address register
shuffling, as it cannot do some operations on address registers (like shifting
or multiplication) (KB) }
second_incdec_tempregdef:=cgsize_orddef(def_cgsize(left.resultdef));
end;
begin
cinlinenode:=t68kinlinenode;
end.

22
compiler/ncginl.pas
View File

@ -26,7 +26,7 @@ unit ncginl;
interface
uses
node,ninl;
node,ninl,symtype;
type
tcginlinenode = class(tinlinenode)
@ -66,6 +66,8 @@ interface
procedure second_seg; virtual; abstract;
procedure second_fma; virtual;
procedure second_frac_real; virtual;
protected
function second_incdec_tempregdef: tdef;virtual;
end;
implementation
@ -73,7 +75,7 @@ implementation
uses
globtype,constexp,
verbose,globals,compinnr,
symconst,symtype,symdef,defutil,
symconst,symdef,defutil,
aasmbase,aasmdata,
cgbase,pass_2,
cpubase,procinfo,
@ -162,6 +164,13 @@ implementation
if location.loc in [LOC_CREFERENCE,LOC_REFERENCE] then
location.reference.alignment:=resultdef.alignment;
end;
in_volatile_x:
begin
secondpass(tcallparanode(left).left);
location:=tcallparanode(left).left.location;
if location.loc in [LOC_CREFERENCE,LOC_REFERENCE,LOC_SUBSETREF,LOC_CSUBSETREF] then
location.reference.volatility:=[vol_read,vol_write];
end;
{$ifdef SUPPORT_MMX}
in_mmx_pcmpeqb..in_mmx_pcmpgtw:
begin
@ -332,6 +341,11 @@ implementation
{*****************************************************************************
INC/DEC GENERIC HANDLING
*****************************************************************************}
function tcginlinenode.second_incdec_tempregdef: tdef;
begin
second_incdec_tempregdef:=left.resultdef;
end;
procedure tcginlinenode.second_IncDec;
const
addsubop:array[in_inc_x..in_dec_x] of TOpCG=(OP_ADD,OP_SUB);
@ -382,7 +396,7 @@ implementation
addvalue:=addvalue*tpointerconstnode(tcallparanode(tcallparanode(left).right).left).value
else
begin
hlcg.location_force_reg(current_asmdata.CurrAsmList,tcallparanode(tcallparanode(left).right).left.location,tcallparanode(tcallparanode(left).right).left.resultdef,left.resultdef,addvalue<=1);
hlcg.location_force_reg(current_asmdata.CurrAsmList,tcallparanode(tcallparanode(left).right).left.location,tcallparanode(tcallparanode(left).right).left.resultdef,second_incdec_tempregdef,addvalue<=1);
hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
{$ifndef cpu64bitalu}
hregisterhi:=tcallparanode(tcallparanode(left).right).left.location.register64.reghi;
@ -684,7 +698,7 @@ implementation
tempreg1:=hlcg.getintregister(current_asmdata.CurrAsmList,left.resultdef);
tempreg2:=hlcg.getintregister(current_asmdata.CurrAsmList,left.resultdef);
hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SAR,left.resultdef,left.resultdef.size*8-1,left.location.register,tempreg1);
hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_XOR,left.resultdef,left.location.register,tempreg1,tempreg2);
hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmlist,OP_SUB,left.resultdef,tempreg1,tempreg2,location.register);

9
compiler/ninl.pas
View File

@ -3555,6 +3555,12 @@ implementation
begin
resultdef:=left.resultdef;
end;
in_volatile_x:
begin
resultdef:=left.resultdef;
{ volatile only makes sense if the value is in memory }
make_not_regable(left,[ra_addr_regable]);
end;
in_assert_x_y :
begin
resultdef:=voidtype;
@ -4044,7 +4050,8 @@ implementation
expectloc:=LOC_VOID;
end;
in_aligned_x,
in_unaligned_x:
in_unaligned_x,
in_volatile_x:
begin
expectloc:=tcallparanode(left).left.expectloc;
end;

1
compiler/nutils.pas
View File

@ -891,6 +891,7 @@ implementation
in_abs_real,
in_aligned_x,
in_unaligned_x,
in_volatile_x,
in_prefetch_var:
begin
inc(result);

3
compiler/pexpr.pas
View File

@ -515,7 +515,8 @@ implementation
end;
in_aligned_x,
in_unaligned_x :
in_unaligned_x,
in_volatile_x:
begin
err:=false;
consume(_LKLAMMER);

1
compiler/psystem.pas
View File

@ -103,6 +103,7 @@ implementation
{$endif SUPPORT_GET_FRAME}
systemunit.insert(csyssym.create('Unaligned',in_unaligned_x));
systemunit.insert(csyssym.create('Aligned',in_aligned_x));
systemunit.insert(csyssym.create('Volatile',in_volatile_x));
systemunit.insert(csyssym.create('ObjCSelector',in_objc_selector_x)); { objc only }
systemunit.insert(csyssym.create('ObjCEncode',in_objc_encode_x)); { objc only }
systemunit.insert(csyssym.create('Default',in_default_x));

4
compiler/raatt.pas
View File

@ -1340,9 +1340,9 @@ unit raatt;
if actasmtoken=AS_COMMA then
begin
Consume(AS_COMMA);
if actasmtoken=AS_MOD then
if (actasmtoken=AS_MOD) or (actasmtoken=AS_AT) then
begin
Consume(AS_MOD);
Consume(actasmtoken);
if actasmtoken=AS_ID then
begin
case actasmpattern of

10
compiler/x86/aoptx86.pas
View File

@ -218,7 +218,9 @@ unit aoptx86;
(r1.segment = r2.segment) and (r1.base = r2.base) and
(r1.index = r2.index) and (r1.scalefactor = r2.scalefactor) and
(r1.symbol=r2.symbol) and (r1.refaddr = r2.refaddr) and
(r1.relsymbol = r2.relsymbol);
(r1.relsymbol = r2.relsymbol) and
(r1.volatility=[]) and
(r2.volatility=[]);
end;
@ -232,7 +234,8 @@ unit aoptx86;
((base=NR_INVALID) or
(ref.base=base)) and
((index=NR_INVALID) or
(ref.index=index));
(ref.index=index)) and
(ref.volatility=[]);
end;
@ -245,7 +248,8 @@ unit aoptx86;
((base=NR_INVALID) or
(ref.base=base)) and
((index=NR_INVALID) or
(ref.index=index));
(ref.index=index)) and
(ref.volatility=[]);
end;

14
packages/pastojs/fpmake.pp
View File

@ -44,7 +44,11 @@ begin
T:=P.Targets.AddUnit('fppas2js.pp');
T.ResourceStrings:=true;
T:=P.Targets.AddUnit('fppjssrcmap.pp');
T:=P.Targets.AddUnit('pas2jsfs.pp');
T:=P.Targets.AddUnit('pas2jsutils.pp');
T:=P.Targets.AddUnit('pas2jsfilecache.pp');
T.Dependencies.AddUnit('pas2jsfs');
T.Dependencies.AddUnit('pas2jsutils');
T:=P.Targets.AddUnit('pas2jsfileutils.pp');
T.Dependencies.AddInclude('pas2js_defines.inc');
T.Dependencies.AddInclude('pas2jsfileutilsunix.inc',AllUnixOSes);
@ -52,10 +56,18 @@ begin
T:=P.Targets.AddUnit('pas2jslogger.pp');
T:=P.Targets.AddUnit('pas2jspparser.pp');
T:=P.Targets.AddUnit('pas2jscompiler.pp');
T:=P.Targets.AddUnit('pas2jsfscompiler.pp');
T.Dependencies.AddUnit('pas2jscompiler');
T:=P.Targets.AddUnit('pas2jspcucompiler.pp');
T.Dependencies.AddUnit('pas2jsfscompiler');
T:=P.Targets.AddUnit('pas2jscompilercfg.pp');
T.Dependencies.AddUnit('pas2jscompiler');
T:=P.Targets.AddUnit('pas2jscompilerpp.pp');
T.Dependencies.AddUnit('pas2jscompiler');
T:=P.Targets.AddUnit('pas2jslibcompiler.pp');
T.Dependencies.AddUnit('pas2jscompiler');
T.Dependencies.AddUnit('pas2jspcucompiler');
T.Dependencies.AddUnit('pas2jscompilercfg');
T.Dependencies.AddUnit('pas2jscompilerpp');
{$ifndef ALLPACKAGES}
Run;
end;

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

@ -354,7 +354,6 @@ Works:
- typecast byte(longword) -> value & $ff
- typecast TJSFunction(func)
- modeswitch OmitRTTI
- debugger;
ToDos:
- do not rename property Date
@ -1263,11 +1262,8 @@ type
procedure ComputeBinaryExprRes(Bin: TBinaryExpr; out
ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
var LeftResolved, RightResolved: TPasResolverResult); override;
// built-in functions
procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out ResolvedEl: TPasResolverResult); override;
function BI_Debugger_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
public
constructor Create; reintroduce;
destructor Destroy; override;
@ -1752,7 +1748,6 @@ type
Function ConvertBuiltIn_New(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_Default(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_Debugger(El: TPasExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement; virtual;
Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
@ -4236,16 +4231,6 @@ begin
if Proc=nil then ;
end;
function TPas2JSResolver.BI_Debugger_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
// debugger;
begin
if Expr is TParamsExpr then
Result:=CheckBuiltInMaxParamCount(Proc,TParamsExpr(Expr),0,RaiseOnError)
else
Result:=cExact;
end;
constructor TPas2JSResolver.Create;
var
bt: TPas2jsBaseType;
@ -4336,9 +4321,6 @@ begin
AddBaseType(Pas2JSBuiltInNames[pbitnUIntDouble],btUIntDouble);
if btIntDouble in TheBaseTypes then
AddBaseType(Pas2JSBuiltInNames[pbitnIntDouble],btIntDouble);
AddBuiltInProc('Debugger','procedure Debugger',
@BI_Debugger_OnGetCallCompatibility,nil,
nil,nil,bfCustom,[bipfCanBeStatement]);
end;
function TPas2JSResolver.CheckTypeCastRes(const FromResolved,
@ -7302,12 +7284,6 @@ begin
bfBreak: Result:=ConvertBuiltInBreak(El,AContext);
bfContinue: Result:=ConvertBuiltInContinue(El,AContext);
bfExit: Result:=ConvertBuiltIn_Exit(El,AContext);
bfCustom:
case BuiltInProc.Element.Name of
'Debugger': Result:=ConvertBuiltIn_Debugger(El,AContext);
else
RaiseNotSupported(El,AContext,20181126102554,'built in custom proc '+BuiltInProc.Element.Name);
end
else
RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
end;
@ -8407,12 +8383,6 @@ begin
if Result=nil then exit;
end;
bfDefault: Result:=ConvertBuiltIn_Default(El,AContext);
bfCustom:
case BuiltInProc.Element.Name of
'Debugger': Result:=ConvertBuiltIn_Debugger(El,AContext);
else
RaiseNotSupported(El,AContext,20181126101801,'built in custom proc '+BuiltInProc.Element.Name);
end;
else
RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
end;
@ -11003,13 +10973,6 @@ begin
AContext.Resolver.GetResolverResultDescription(ResolvedEl)],Param);
end;
function TPasToJSConverter.ConvertBuiltIn_Debugger(El: TPasExpr;
AContext: TConvertContext): TJSElement;
begin
Result:=CreateLiteralCustomValue(El,'debugger');
if AContext=nil then ;
end;
function TPasToJSConverter.ConvertRecordValues(El: TRecordValues;
AContext: TConvertContext): TJSElement;
var

5
packages/pastojs/src/pas2js_defines.inc
View File

@ -19,6 +19,11 @@
{$DEFINE UTF8_RTL}
{$DEFINE HasStdErr}
{$DEFINE HasPas2jsFiler}
{$DEFINE HASFILESYSTEM}
{$ENDIF}
{$IFDEF NODEJS}
{$DEFINE HASFILESYSTEM}
{$ENDIF}

1572
packages/pastojs/src/pas2jscompiler.pp
View File

File diff suppressed because it is too large Load Diff

95
packages/pastojs/src/pas2jscompilercfg.pp Normal file
View File

@ -0,0 +1,95 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
Config file handling for compiler, depends on filesystem.
}
unit pas2jscompilercfg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, pas2JSCompiler, pas2jsfs;
Type
TPas2JSFileConfigSupport = Class(TPas2JSConfigSupport)
function FindDefaultConfig: String; override;
function GetReader(aFileName: string): TSourceLineReader; override;
end;
implementation
uses pas2jsfileutils;
function TPas2JSFileConfigSupport.GetReader(aFileName: string): TSourceLineReader;
Var
CacheFile: TPas2jsFile;
begin
CacheFile:=Compiler.FS.LoadFile(aFilename);
Result:=CacheFile.CreateLineReader(true);
end;
Function TPas2JSFileConfigSupport.FindDefaultConfig : String;
function TryConfig(aFilename: string): boolean;
begin
Result:=false;
if aFilename='' then exit;
aFilename:=ExpandFileName(aFilename);
if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
Compiler.Log.LogMsgIgnoreFilter(nConfigFileSearch,[aFilename]);
if not Compiler.FS.FileExists(aFilename) then exit;
Result:=true;
end;
var
aFilename: String;
begin
// first try HOME directory
aFilename:=ChompPathDelim(GetEnvironmentVariablePJ('HOME'));
if aFilename<>'' then
begin
aFilename:=aFilename+PathDelim{$IFDEF UNIX}+'.'{$ENDIF}+DefaultConfigFile;
if TryConfig(aFileName) then
exit(aFileName);
end;
// then try compiler directory
if (Compiler.CompilerExe<>'') then
begin
aFilename:=ExtractFilePath(Compiler.CompilerExe);
if aFilename<>'' then
begin
aFilename:=IncludeTrailingPathDelimiter(aFilename)+DefaultConfigFile;
if TryConfig(aFilename) then
exit(aFileName);
end;
end;
// finally try global directory
{$IFDEF Unix}
if TryConfig('/etc/'+DefaultConfigFile) then
exit(aFileName);
{$ENDIF}
end;
end.

262
packages/pastojs/src/pas2jscompilerpp.pp Normal file
View File

@ -0,0 +1,262 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
Pas2JS compiler Preprocessor support. Can depend on filesystem.
}
unit pas2jscompilerpp;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, pas2jscompiler, jswriter, FPPJSSrcMap, contnrs;
Type
{ TPas2JSFSPostProcessorSupport }
TPas2JSFSPostProcessorSupport = Class(TPas2JSPostProcessorSupport)
Private
FPostProcs: TObjectList;
function CmdListAsStr(CmdList: TStrings): string;
Public
Constructor Create(aCompiler: TPas2JSCompiler); override;
Destructor Destroy; override;
Procedure Clear; override;
Procedure WriteUsedTools; override;
Procedure AddPostProcessor(const Cmd: String); override;
Procedure CallPostProcessors(const JSFileName: String; aWriter: TPas2JSMapper); override;
function Execute(const JSFilename: String; Cmd: TStringList; JS: TJSWriterString): TJSWriterString;
end;
implementation
uses process, pas2jslogger, pas2jsutils, pas2jsfileutils;
function TPas2JSFSPostProcessorSupport.CmdListAsStr(CmdList: TStrings): string;
var
i: Integer;
begin
Result:='';
for i:=0 to CmdList.Count-1 do
begin
if Result<>'' then Result+=' ';
Result+=QuoteStr(CmdList[i]);
end;
end;
constructor TPas2JSFSPostProcessorSupport.Create(aCompiler: TPas2JSCompiler);
begin
inherited Create(aCompiler);
FPostProcs:=TObjectList.Create; // Owns objects
end;
destructor TPas2JSFSPostProcessorSupport.Destroy;
begin
FreeAndNil(FPostProcs);
inherited Destroy;
end;
procedure TPas2JSFSPostProcessorSupport.Clear;
begin
FPostProcs.Clear;
end;
procedure TPas2JSFSPostProcessorSupport.WriteUsedTools;
Var
I : integer;
PostProc : TStringList;
begin
// post processors
for i:=0 to FPostProcs.Count-1 do
begin
PostProc:=TStringList(FPostProcs[i]);
Compiler.Log.LogMsgIgnoreFilter(nPostProcessorInfoX,[CmdListAsStr(PostProc)]);
end;
end;
procedure TPas2JSFSPostProcessorSupport.AddPostProcessor(const Cmd: String);
Var
PostProc : TStringList;
S : String;
begin
PostProc:=TStringList.Create;
FPostProcs.Add(PostProc);
SplitCmdLineParams(Cmd,PostProc);
if PostProc.Count<1 then
Compiler.ParamFatal('-Jpcmd executable missing');
// check executable
S:=Compiler.FS.ExpandExecutable(PostProc[0]);
if (S='') then
Compiler.ParamFatal('-Jpcmd executable "'+S+'" not found');
PostProc[0]:=S;
end;
procedure TPas2JSFSPostProcessorSupport.CallPostProcessors(const JSFileName: String; aWriter: TPas2JSMapper);
var
i: Integer;
JS, OrigJS: TJSWriterString;
begin
if FPostProcs.Count=0 then exit;
OrigJS:=aWriter.AsString;
JS:=OrigJS;
for i:=0 to FPostProcs.Count-1 do
JS:=Execute(JSFilename,TStringList(FPostProcs[i]),JS);
if JS<>OrigJS then
begin
aWriter.AsString:=JS;
if aWriter.SrcMap<>nil then
aWriter.SrcMap.Clear;
end;
end;
function TPas2JSFSPostProcessorSupport.Execute(const JSFilename: String; Cmd: TStringList; JS: TJSWriterString): TJSWriterString;
const
BufSize = 65536;
var
Exe: String;
TheProcess: TProcess;
WrittenBytes, ReadBytes: LongInt;
Buf, s, ErrBuf: string;
OutputChunks: TStringList;
CurExitCode, i, InPos: Integer;
begin
Result:='';
Buf:='';
Exe:=Cmd[0];
if Compiler.ShowDebug or Compiler.ShowUsedTools then
Compiler.Log.LogMsgIgnoreFilter(nPostProcessorRunX,[QuoteStr(JSFilename)+' | '+CmdListAsStr(Cmd)]);
if Compiler.FS.DirectoryExists(Exe) then
raise EFOpenError.Create('post processor "'+Exe+'" is a directory');
if not FileIsExecutable(Exe) then
raise EFOpenError.Create('post processor "'+Exe+'" is a not executable');
try
TheProcess := TProcess.Create(nil);
OutputChunks:=TStringList.Create;
try
TheProcess.Executable := Exe;
for i:=1 to Cmd.Count-1 do
TheProcess.Parameters.Add(Cmd[i]);
TheProcess.Options:= [poUsePipes];
TheProcess.ShowWindow := swoHide;
//TheProcess.CurrentDirectory:=WorkingDirectory;
TheProcess.Execute;
ErrBuf:='';
SetLength(Buf,BufSize);
InPos:=1;
repeat
// read stderr and log immediately as warnings
repeat
if TheProcess.Stderr.NumBytesAvailable=0 then break;
ReadBytes:=TheProcess.Stderr.Read(Buf[1],BufSize);
if ReadBytes=0 then break;
ErrBuf+=LeftStr(Buf,ReadBytes);
repeat
i:=1;
while (i<=length(ErrBuf)) and (i<128) and not (ErrBuf[i] in [#10,#13]) do
inc(i);
if i>length(ErrBuf) then break;
Compiler.Log.LogMsg(nPostProcessorWarnX,[LeftStr(ErrBuf,i)]);
if (i<=length(ErrBuf)) and (ErrBuf[i] in [#10,#13]) then
begin
// skip linebreak
if (i<length(ErrBuf)) and (ErrBuf[i+1] in [#10,#13])
and (ErrBuf[i]<>ErrBuf[i+1]) then
inc(i,2)
else
inc(i);
end;
Delete(ErrBuf,1,i-1);
until false;
until false;
// write to stdin
if InPos<length(JS) then
begin
i:=length(JS)-InPos+1;
if i>BufSize then i:=BufSize;
WrittenBytes:=TheProcess.Input.Write(JS[InPos],i);
inc(InPos,WrittenBytes);
if InPos>length(JS) then
TheProcess.CloseInput;
end else
WrittenBytes:=0;
// read stdout
if TheProcess.Output.NumBytesAvailable=0 then
ReadBytes:=0
else
ReadBytes:=TheProcess.Output.Read(Buf[1],BufSize);
if ReadBytes>0 then
OutputChunks.Add(LeftStr(Buf,ReadBytes));
if (WrittenBytes=0) and (ReadBytes=0) then
begin
if not TheProcess.Running then break;
Sleep(10); // give tool some time
end;
until false;
TheProcess.WaitOnExit;
CurExitCode:=TheProcess.ExitCode;
// concatenate output chunks
ReadBytes:=0;
for i:=0 to OutputChunks.Count-1 do
inc(ReadBytes,length(OutputChunks[i]));
SetLength(Result,ReadBytes);
ReadBytes:=0;
for i:=0 to OutputChunks.Count-1 do
begin
s:=OutputChunks[i];
if s='' then continue;
System.Move(s[1],Result[ReadBytes+1],length(s));
inc(ReadBytes,length(s));
end;
finally
OutputChunks.Free;
TheProcess.Free;
end;
except
on E: Exception do begin
if Compiler.ShowDebug then
Compiler.Log.LogExceptionBackTrace(E);
Compiler.Log.LogPlain('Error: '+E.Message);
Compiler.Log.LogMsg(nPostProcessorFailX,[CmdListAsStr(Cmd)]);
Compiler.Terminate(ExitCodeToolError);
end
{$IFDEF Pas2js}
else HandleJSException('[20181118170506] TPas2jsCompiler.CallPostProcessor Cmd: '+CmdListAsStr(Cmd),JSExceptValue,true);
{$ENDIF}
end;
if CurExitCode<>0 then
begin
Compiler.Log.LogMsg(nPostProcessorFailX,[CmdListAsStr(Cmd)]);
Compiler.Terminate(ExitCodeToolError);
end;
if Compiler.ShowDebug or Compiler.ShowUsedTools then
Compiler.Log.LogMsgIgnoreFilter(nPostProcessorFinished,[]);
end;
end.

422
packages/pastojs/src/pas2jsfilecache.pp
View File

@ -32,20 +32,11 @@ uses
{$ENDIF}
Classes, SysUtils,
fpjson,
PScanner, PasUseAnalyzer, PasResolver, Pas2jsLogger, Pas2jsFileUtils;
PScanner, PasUseAnalyzer, PasResolver, Pas2jsLogger, Pas2jsFileUtils, pas2jsfs;
const // Messages
nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s';
nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found';
nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found';
nDuplicateFileFound = 205; sDuplicateFileFound = 'Duplicate file found: "%s" and "%s"';
nCustomJSFileNotFound = 206; sCustomJSFileNotFound = 'custom JS file not found: "%s"';
nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
type
EPas2jsFileCache = class(Exception);
EPas2jsFileCache = class(EPas2JSFS);
type
TPas2jsFileAgeTime = longint;
@ -87,7 +78,7 @@ type
function Count: integer;
procedure Clear;
property ChangeStamp: TChangeStamp read FChangeStamp write FChangeStamp;// set on Update to Pool.ChangeStamp
function NeedsUpdate: boolean; inline;
function NeedsUpdate: boolean;
procedure Update;
procedure Reference;
procedure Release;
@ -159,93 +150,58 @@ type
property OnReadDirectory: TReadDirectoryEvent read FOnReadDirectory write FOnReadDirectory;
end;
type
TP2jsFileCacheOption = (
caoShowFullFilenames,
caoShowTriedUsedFiles,
caoSearchLikeFPC,
caoStrictFileCase
);
TP2jsFileCacheOptions = set of TP2jsFileCacheOption;
const
DefaultPas2jsFileCacheOptions = [];
p2jsfcoCaption: array[TP2jsFileCacheOption] of string = (
// only used by experts, no need for resourcestrings
'Show full filenames',
'Show tried/used files',
'Search files like FPC',
'Strict file case'
);
// 'Combine all JavaScript into main file',
EncodingBinary = 'Binary';
type
TPas2jsFilesCache = class;
TPas2jsCachedFile = class;
{ TPas2jsFileResolver }
TPas2jsFileResolver = class(TFileResolver)
TPas2jsFileResolver = class(TPas2JSFSResolver)
private
FCache: TPas2jsFilesCache;
function GetCache: TPas2jsFilesCache;
public
constructor Create(aCache: TPas2jsFilesCache); reintroduce;
// Redirect all calls to cache.
function FindIncludeFileName(const aFilename: string): String; override;
function FindIncludeFile(const aFilename: string): TLineReader; override;
function FindSourceFile(const aFilename: string): TLineReader; override;
property Cache: TPas2jsFilesCache read FCache;
property Cache: TPas2jsFilesCache read GetCache;
end;
{ TPas2jsFileLineReader }
TPas2jsFileLineReader = class(TLineReader)
TPas2jsFileLineReader = class(TSourceLineReader)
private
FCachedFile: TPas2jsCachedFile;
FIsEOF: boolean;
FLineNumber: integer;
FSource: string;
FSrcPos: integer;
Protected
Procedure IncLineNumber; override;
property CachedFile: TPas2jsCachedFile read FCachedFile;
public
constructor Create(const AFilename: string); override;
constructor Create(aFile: TPas2jsCachedFile); reintroduce;
function IsEOF: Boolean; override;
function ReadLine: string; override;
property LineNumber: integer read FLineNumber;
property CachedFile: TPas2jsCachedFile read FCachedFile;
property Source: string read FSource;
property SrcPos: integer read FSrcPos;
end;
{ TPas2jsCachedFile }
TPas2jsCachedFile = class
TPas2jsCachedFile = class(TPas2JSFile)
private
FCache: TPas2jsFilesCache;
FChangeStamp: TChangeStamp;
FFileEncoding: string;
FFilename: string;
FLastErrorMsg: string;
FLoaded: boolean;
FLoadedFileAge: longint;
FSource: string;
FCacheStamp: TChangeStamp; // Cache.ResetStamp when file was loaded
function GetCache: TPas2jsFilesCache;
function GetIsBinary: boolean; inline;
public
constructor Create(aCache: TPas2jsFilesCache; const aFilename: string); reintroduce;
function Load(RaiseOnError: boolean; Binary: boolean = false): boolean;
function CreateLineReader(RaiseOnError: boolean): TPas2jsFileLineReader;
Protected
property IsBinary: boolean read GetIsBinary;
property FileEncoding: string read FFileEncoding;
property Filename: string read FFilename;
property Source: string read FSource; // UTF-8 without BOM or Binary
property Cache: TPas2jsFilesCache read FCache;
property Cache: TPas2jsFilesCache read GetCache;
property ChangeStamp: TChangeStamp read FChangeStamp;// changed when Source changed
property Loaded: boolean read FLoaded; // Source valid, but may contain an old version
property LastErrorMsg: string read FLastErrorMsg;
property LoadedFileAge: longint read FLoadedFileAge;// only valid if Loaded=true
public
constructor Create(aCache: TPas2jsFilesCache; const aFilename: string); reintroduce;
function Load(RaiseOnError: boolean; Binary: boolean = false): boolean; override;
function CreateLineReader(RaiseOnError: boolean): TSourceLineReader; override;
end;
TPas2jsReadFileEvent = function(aFilename: string; var aSource: string): boolean of object;
@ -258,10 +214,9 @@ type
{ TPas2jsFilesCache }
TPas2jsFilesCache = class
TPas2jsFilesCache = class (TPas2JSFS)
private
FBaseDirectory: string;
FDefaultOutputPath: string;
FDirectoryCache: TPas2jsCachedDirectories;
FFiles: TPasAnalyzerKeySet; // set of TPas2jsCachedFile, key is Filename
FForeignUnitPaths: TStringList;
@ -269,19 +224,14 @@ type
FIncludePaths: TStringList;
FIncludePathsFromCmdLine: integer;
FLog: TPas2jsLogger;
FNamespaces: TStringList;
FNamespacesFromCmdLine: integer;
FOnReadFile: TPas2jsReadFileEvent;
FOnWriteFile: TPas2jsWriteFileEvent;
FOptions: TP2jsFileCacheOptions;
FReadLineCounter: SizeInt;
FResetStamp: TChangeStamp;
FUnitOutputPath: string;
FUnitPaths: TStringList;
FUnitPathsFromCmdLine: integer;
function FileExistsILogged(var Filename: string): integer;
function FileExistsLogged(const Filename: string): boolean;
function FindSourceFileName(const aFilename: string): String;
function GetOnReadDirectory: TReadDirectoryEvent;
function GetSearchLikeFPC: boolean;
function GetShowFullFilenames: boolean;
function GetShowTriedUsedFiles: boolean;
@ -290,70 +240,66 @@ type
procedure SetBaseDirectory(AValue: string);
function AddSearchPaths(const Paths: string; Kind: TPas2jsSearchPathKind;
FromCmdLine: boolean; var List: TStringList; var CmdLineCount: integer): string;
procedure SetDefaultOutputPath(AValue: string);
procedure SetOptions(AValue: TP2jsFileCacheOptions);
procedure SetOnReadDirectory(AValue: TReadDirectoryEvent);
procedure SetSearchLikeFPC(const AValue: boolean);
procedure SetShowFullFilenames(const AValue: boolean);
procedure SetShowTriedUsedFiles(const AValue: boolean);
procedure SetStrictFileCase(AValue: Boolean);
procedure SetUnitOutputPath(AValue: string);
procedure SetOption(Flag: TP2jsFileCacheOption; Enable: boolean);
protected
function FindSourceFileName(const aFilename: string): String; override;
function GetHasPCUSupport: Boolean; virtual;
function ReadFile(Filename: string; var Source: string): boolean; virtual;
procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings);// find files, matching * and ?
public
constructor Create(aLog: TPas2jsLogger);
constructor Create(aLog: TPas2jsLogger); overload;
destructor Destroy; override;
procedure Reset; virtual;
procedure WriteFoldersAndSearchPaths; virtual;
procedure Reset; override;
procedure WriteFoldersAndSearchPaths; override;
procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); override;
Function SameFileName(Const File1,File2 : String) : Boolean; override;
Function File1IsNewer(const File1, File2: String): Boolean; override;
function SearchLowUpCase(var Filename: string): boolean;
function FindCustomJSFileName(const aFilename: string): String;
function FindUnitJSFileName(const aUnitFilename: string): String;
function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; virtual;
function FindIncludeFileName(const aFilename: string): String; virtual;
function FindCustomJSFileName(const aFilename: string): String; override;
function FindUnitJSFileName(const aUnitFilename: string): String; override;
function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
function FindIncludeFileName(const aFilename: string): String; override;
function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function AddNamespaces(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function AddSrcUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function CreateResolver: TPas2jsFileResolver;
function FormatPath(const aPath: string): string;
Function DirectoryExists(Filename: string): boolean; virtual;
function FileExists(Filename: string): boolean; virtual;
function CreateResolver: TPas2jsFSResolver; override;
function FormatPath(const aPath: string): string; override;
Function DirectoryExists(Const Filename: string): boolean; override;
function FileExists(const Filename: string): boolean; override;
function FileExistsI(var Filename: string): integer; // returns number of found files
function FileAge(const Filename: string): TPas2jsFileAgeTime; virtual;
function FindFile(Filename: string): TPas2jsCachedFile;
function LoadFile(Filename: string; Binary: boolean = false): TPas2jsCachedFile;
function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; override;
function NormalizeFilename(const Filename: string; RaiseOnError: boolean): string;
procedure GetListing(const aDirectory: string; var Files: TStrings;
FullPaths: boolean = true);
procedure RaiseDuplicateFile(aFilename: string);
procedure SaveToFile(ms: TFPJSStream; Filename: string);
function ExpandDirectory(const Filename, BaseDir: string): string;
function ExpandExecutable(const Filename, BaseDir: string): string;
procedure SaveToFile(ms: TFPJSStream; Filename: string); override;
function ExpandDirectory(const Filename: string): string; override;
function ExpandFileName(const Filename: string): string; override;
function ExpandExecutable(const Filename: string): string; override;
function HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String; override;
Function AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String; override;
function TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String): Boolean; override;
Protected
property DirectoryCache: TPas2jsCachedDirectories read FDirectoryCache;
public
property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; // includes trailing pathdelim
property MainOutputPath: string read FDefaultOutputPath write SetDefaultOutputPath; // includes trailing pathdelim
property DirectoryCache: TPas2jsCachedDirectories read FDirectoryCache;
property ForeignUnitPaths: TStringList read FForeignUnitPaths;
property ForeignUnitPathsFromCmdLine: integer read FForeignUnitPathsFromCmdLine;
property IncludePaths: TStringList read FIncludePaths;
property IncludePathsFromCmdLine: integer read FIncludePathsFromCmdLine;
property Log: TPas2jsLogger read FLog;
property Namespaces: TStringList read FNamespaces;
property NamespacesFromCmdLine: integer read FNamespacesFromCmdLine;
property Options: TP2jsFileCacheOptions read FOptions write SetOptions default DefaultPas2jsFileCacheOptions;
property ReadLineCounter: SizeInt read FReadLineCounter write FReadLineCounter;
property ResetStamp: TChangeStamp read FResetStamp;
property SearchLikeFPC: boolean read GetSearchLikeFPC write SetSearchLikeFPC;
property ShowFullPaths: boolean read GetShowFullFilenames write SetShowFullFilenames;
property ShowTriedUsedFiles: boolean read GetShowTriedUsedFiles write SetShowTriedUsedFiles;
property UnitOutputPath: string read FUnitOutputPath write SetUnitOutputPath; // includes trailing pathdelim
property UnitPaths: TStringList read FUnitPaths;
property UnitPathsFromCmdLine: integer read FUnitPathsFromCmdLine;
property OnReadDirectory: TReadDirectoryEvent read GetOnReadDirectory write SetOnReadDirectory;
property OnReadFile: TPas2jsReadFileEvent read FOnReadFile write FOnReadFile;
property OnWriteFile: TPas2jsWriteFileEvent read FOnWriteFile write FOnWriteFile;
Property StrictFileCase : Boolean Read GetStrictFileCase Write SetStrictFileCase;
end;
@ -409,6 +355,7 @@ var
begin
Result:=FilenameToKey(Dir.Path);
end;
{$ELSE}
function CompareFilenameWithCachedFile(Filename, CachedFile: Pointer): integer;
var
@ -439,6 +386,7 @@ var
begin
Result:=CompareFilenames(AnsiString(Path),Directory.Path);
end;
{$ENDIF}
function ComparePas2jsDirectoryEntries(Entry1, Entry2: {$IFDEF Pas2js}jsvalue{$ELSE}Pointer{$ENDIF}): integer;
@ -614,6 +562,7 @@ begin
FPath:=IncludeTrailingPathDelimiter(aPath);
FEntries:=TFPList.Create;
FPool:=aPool;
FChangeStamp:=InvalidChangeStamp;
end;
destructor TPas2jsCachedDirectory.Destroy;
@ -1105,6 +1054,13 @@ end;
{ TPas2jsFileLineReader }
procedure TPas2jsFileLineReader.IncLineNumber;
begin
if (CachedFile<>nil) and (CachedFile.Cache<>nil) then
CachedFile.Cache.IncReadLineCounter;
inherited IncLineNumber;
end;
constructor TPas2jsFileLineReader.Create(const AFilename: string);
begin
raise Exception.Create('TPas2jsFileLineReader.Create [20180126090825] no cache "'+AFilename+'"');
@ -1112,60 +1068,10 @@ end;
constructor TPas2jsFileLineReader.Create(aFile: TPas2jsCachedFile);
begin
inherited Create(aFile.Filename);
inherited Create(aFile.Filename,aFile.Source);
FCachedFile:=aFile;
FSource:=aFile.Source;
FSrcPos:=1;
FIsEOF:=FSource='';
end;
function TPas2jsFileLineReader.IsEOF: Boolean;
begin
Result:=FIsEOF;
end;
function TPas2jsFileLineReader.ReadLine: string;
var
S: string;
p, SrcLen: integer;
procedure GetLine;
var
l: SizeInt;
begin
l:=p-FSrcPos;
Result:=copy(S,FSrcPos,l);
FSrcPos:=p;
inc(FLineNumber);
if (CachedFile<>nil) and (CachedFile.Cache<>nil) then
inc(CachedFile.Cache.FReadLineCounter);
//writeln('GetLine "',Result,'"');
end;
begin
if FIsEOF then exit('');
S:=Source;
SrcLen:=length(S);
p:=FSrcPos;
while p<=SrcLen do
case S[p] of
#10,#13:
begin
GetLine;
inc(p);
if (p<=SrcLen) and (S[p] in [#10,#13]) and (S[p]<>S[p-1]) then
inc(p);
if p>SrcLen then
FIsEOF:=true;
FSrcPos:=p;
exit;
end;
else
inc(p);
end;
FIsEOF:=true;
GetLine;
end;
{ TPas2jsCachedFile }
@ -1175,13 +1081,17 @@ begin
Result:=FFileEncoding=EncodingBinary;
end;
function TPas2jsCachedFile.GetCache: TPas2jsFilesCache;
begin
Result:=TPas2jsFilesCache(FS);
end;
constructor TPas2jsCachedFile.Create(aCache: TPas2jsFilesCache;
const aFilename: string);
begin
inHerited Create(aCache,aFileName);
FChangeStamp:=InvalidChangeStamp;
FCache:=aCache;
FCacheStamp:=Cache.ResetStamp;
FFilename:=aFilename;
end;
function TPas2jsCachedFile.Load(RaiseOnError: boolean; Binary: boolean
@ -1254,14 +1164,14 @@ begin
{$ENDIF}
if Binary then
begin
FSource:=NewSource;
SetSource(NewSource);
FFileEncoding:=EncodingBinary;
end else
begin
{$IFDEF FPC_HAS_CPSTRING}
FSource:=ConvertTextToUTF8(NewSource,FFileEncoding);
SetSource(ConvertTextToUTF8(NewSource,FFileEncoding));
{$ELSE}
FSource:=NewSource;
SetSource(NewSource);
{$ENDIF}
end;
FLoaded:=true;
@ -1273,7 +1183,7 @@ begin
end;
function TPas2jsCachedFile.CreateLineReader(RaiseOnError: boolean
): TPas2jsFileLineReader;
): TSourceLineReader;
begin
if not Load(RaiseOnError) then
exit(nil);
@ -1282,41 +1192,14 @@ end;
{ TPas2jsFileResolver }
function TPas2jsFileResolver.GetCache: TPas2jsFilesCache;
begin
Result:=TPas2jsFilesCache(FS);
end;
constructor TPas2jsFileResolver.Create(aCache: TPas2jsFilesCache);
begin
inherited Create;
FCache:=aCache;
end;
function TPas2jsFileResolver.FindIncludeFile(const aFilename: string): TLineReader;
var
Filename: String;
begin
Result:=nil;
Filename:=Cache.FindIncludeFileName(aFilename);
if Filename='' then exit;
try
Result:=FindSourceFile(Filename);
except
// error is shown in the scanner, which has the context information
end;
end;
function TPas2jsFileResolver.FindIncludeFileName(const aFilename: string): String;
begin
Result:=Cache.FindIncludeFileName(aFilename);
end;
function TPas2jsFileResolver.FindSourceFile(const aFilename: string): TLineReader;
var
CurFilename: String;
begin
CurFilename:=Cache.FindSourceFileName(aFileName);
Result:=Cache.LoadFile(CurFilename).CreateLineReader(false);
inherited Create(aCache);
end;
@ -1340,22 +1223,22 @@ end;
function TPas2jsFilesCache.GetStrictFileCase : Boolean;
begin
Result:=caoStrictFileCase in FOptions;
Result:=caoStrictFileCase in Options;
end;
function TPas2jsFilesCache.GetSearchLikeFPC: boolean;
begin
Result:=caoSearchLikeFPC in FOptions;
Result:=caoSearchLikeFPC in Options;
end;
function TPas2jsFilesCache.GetShowFullFilenames: boolean;
begin
Result:=caoShowFullFilenames in FOptions;
Result:=caoShowFullFilenames in Options;
end;
function TPas2jsFilesCache.GetShowTriedUsedFiles: boolean;
begin
Result:=caoShowTriedUsedFiles in FOptions;
Result:=caoShowTriedUsedFiles in Options;
end;
@ -1456,7 +1339,7 @@ begin
if aPath='' then continue;
if Kind=spkPath then
begin
aPath:=ExpandDirectory(aPath,BaseDirectory);
aPath:=ExpandDirectory(aPath);
if aPath='' then continue;
end;
aPaths.Clear;
@ -1474,18 +1357,9 @@ begin
end;
end;
procedure TPas2jsFilesCache.SetDefaultOutputPath(AValue: string);
procedure TPas2jsFilesCache.SetOnReadDirectory(AValue: TReadDirectoryEvent);
begin
AValue:=ExpandDirectory(AValue,BaseDirectory);
if FDefaultOutputPath=AValue then Exit;
FDefaultOutputPath:=AValue;
end;
procedure TPas2jsFilesCache.SetOptions(AValue: TP2jsFileCacheOptions);
begin
if FOptions=AValue then Exit;
FOptions:=AValue;
DirectoryCache.OnReadDirectory:=AValue;
end;
procedure TPas2jsFilesCache.SetSearchLikeFPC(const AValue: boolean);
@ -1508,23 +1382,6 @@ begin
SetOption(caoStrictFileCase,aValue)
end;
procedure TPas2jsFilesCache.SetUnitOutputPath(AValue: string);
begin
AValue:=ExpandDirectory(AValue,BaseDirectory);
if FUnitOutputPath=AValue then Exit;
FUnitOutputPath:=AValue;
end;
procedure TPas2jsFilesCache.SetOption(Flag: TP2jsFileCacheOption; Enable: boolean
);
begin
if Enable then
Include(FOptions,Flag)
else
Exclude(FOptions,Flag);
end;
function TPas2jsFilesCache.ReadFile(Filename: string; var Source: string
): boolean;
{$IFDEF Pas2js}
@ -1629,10 +1486,8 @@ begin
inherited Create;
FResetStamp:=InvalidChangeStamp;
FLog:=aLog;
FOptions:=DefaultPas2jsFileCacheOptions;
FIncludePaths:=TStringList.Create;
FForeignUnitPaths:=TStringList.Create;
FNamespaces:=TStringList.Create;
FUnitPaths:=TStringList.Create;
FFiles:=TPasAnalyzerKeySet.Create(
{$IFDEF Pas2js}
@ -1652,28 +1507,23 @@ begin
FreeAndNil(FFiles);
FreeAndNil(FIncludePaths);
FreeAndNil(FForeignUnitPaths);
FreeAndNil(FNamespaces);
FreeAndNil(FUnitPaths);
inherited Destroy;
end;
procedure TPas2jsFilesCache.Reset;
begin
Inherited;
IncreaseChangeStamp(FResetStamp);
FDirectoryCache.Invalidate;
// FFiles: keep data, files are checked against LoadedFileAge
FOptions:=DefaultPas2jsFileCacheOptions;
FBaseDirectory:='';
FUnitOutputPath:='';
FReadLineCounter:=0;
FForeignUnitPaths.Clear;
FForeignUnitPathsFromCmdLine:=0;
FUnitPaths.Clear;
FUnitPathsFromCmdLine:=0;
FIncludePaths.Clear;
FIncludePathsFromCmdLine:=0;
FNamespaces.Clear;
FNamespacesFromCmdLine:=0;
// FOnReadFile: TPas2jsReadFileEvent; keep
// FOnWriteFile: TPas2jsWriteFileEvent; keep
end;
@ -1695,14 +1545,28 @@ begin
WriteFolder('foreign unit path',ForeignUnitPaths[i]);
for i:=0 to UnitPaths.Count-1 do
WriteFolder('unit path',UnitPaths[i]);
for i:=0 to Namespaces.Count-1 do
Log.LogMsgIgnoreFilter(nUsingPath,['unit scope',Namespaces[i]]);
for i:=0 to IncludePaths.Count-1 do
WriteFolder('include path',IncludePaths[i]);
WriteFolder('unit output path',UnitOutputPath);
WriteFolder('main output path',MainOutputPath);
end;
procedure TPas2jsFilesCache.GetPCUDirs(aList: TStrings; const aBaseDir: String);
begin
inherited GetPCUDirs(aList, aBaseDir);
aList.AddStrings(UnitPaths);
end;
function TPas2jsFilesCache.SameFileName(const File1, File2: String): Boolean;
begin
Result:=Pas2jsFileUtils.CompareFilenames(File1,File2)=0;
end;
function TPas2jsFilesCache.File1IsNewer(const File1, File2: String): Boolean;
begin
Result:=FileAge(File1)>FileAge(File2);
end;
function TPas2jsFilesCache.AddIncludePaths(const Paths: string;
FromCmdLine: boolean; out ErrorMsg: string): boolean;
begin
@ -1710,12 +1574,6 @@ begin
Result:=ErrorMsg='';
end;
function TPas2jsFilesCache.AddNamespaces(const Paths: string;
FromCmdLine: boolean; out ErrorMsg: string): boolean;
begin
ErrorMsg:=AddSearchPaths(Paths,spkIdentifier,FromCmdLine,FNamespaces,FNamespacesFromCmdLine);
Result:=ErrorMsg='';
end;
function TPas2jsFilesCache.AddUnitPaths(const Paths: string;
FromCmdLine: boolean; out ErrorMsg: string): boolean;
@ -1731,7 +1589,8 @@ begin
Result:=ErrorMsg='';
end;
function TPas2jsFilesCache.CreateResolver: TPas2jsFileResolver;
function TPas2jsFilesCache.CreateResolver: TPas2jsFSResolver;
begin
Result := TPas2jsFileResolver.Create(Self);
{$IFDEF HasStreams}
@ -1759,12 +1618,12 @@ end;
function TPas2jsFilesCache.DirectoryExists(Filename: string): boolean;
function TPas2jsFilesCache.DirectoryExists(Const Filename: string): boolean;
begin
Result:=DirectoryCache.DirectoryExists(FileName);
end;
function TPas2jsFilesCache.FileExists(Filename: string): boolean;
function TPas2jsFilesCache.FileExists(const Filename: string): boolean;
begin
Result:=DirectoryCache.FileExists(FileName);
end;
@ -1786,7 +1645,7 @@ begin
end;
function TPas2jsFilesCache.LoadFile(Filename: string; Binary: boolean
): TPas2jsCachedFile;
): TPas2jsFile;
begin
Result:=FindFile(FileName);
if Result=nil then
@ -1899,20 +1758,20 @@ begin
end;
end;
function TPas2jsFilesCache.ExpandDirectory(const Filename, BaseDir: string
): string;
function TPas2jsFilesCache.ExpandDirectory(const Filename: string): string;
begin
if Filename='' then exit('');
if BaseDir<>'' then
Result:=ExpandFileNamePJ(Filename,BaseDir)
else
Result:=ExpandFileNamePJ(Filename,BaseDirectory);
Result:=ExpandFileNamePJ(Filename,BaseDirectory);
if Result='' then exit;
Result:=IncludeTrailingPathDelimiter(Result);
end;
function TPas2jsFilesCache.ExpandExecutable(const Filename, BaseDir: string
): string;
function TPas2jsFilesCache.ExpandFileName(const Filename: string): string;
begin
Result:=ExpandFileNamePJ(Filename,BaseDirectory);
end;
function TPas2jsFilesCache.ExpandExecutable(const Filename: string): string;
function TryFile(CurFilename: string): boolean;
begin
@ -1933,10 +1792,7 @@ begin
// no file path -> search
{$IFDEF Windows}
// search in BaseDir
if BaseDir<>'' then
begin
if TryFile(IncludeTrailingPathDelimiter(BaseDir)+Filename) then exit;
end else if BaseDirectory<>'' then
if BaseDirectory<>'' then
begin
if TryFile(IncludeTrailingPathDelimiter(BaseDirectory)+Filename) then exit;
end;
@ -1955,10 +1811,38 @@ begin
if CurPath='' then continue;
if TryFile(IncludeTrailingPathDelimiter(CurPath)+Filename) then exit;
end;
end else if BaseDir<>'' then
Result:=ExpandFileNamePJ(Filename,BaseDir)
end else
Result:=ExpandFileName(Filename);
end;
function TPas2jsFilesCache.HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String;
Var
ErrorMsg : String;
begin
Result:='';
case C of
'E': MainOutputPath:=aValue;
'i': if not AddIncludePaths(aValue,FromCmdLine,ErrorMsg) then
Result:='invalid include path (-Fi) "'+ErrorMsg+'"';
'u': if not AddUnitPaths(aValue,FromCmdLine,ErrorMsg) then
Result:='invalid unit path (-Fu) "'+ErrorMsg+'"';
'U': UnitOutputPath:=aValue;
else
Result:=ExpandFileNamePJ(Filename,BaseDirectory);
Result:=inherited HandleOptionPaths(C, aValue, FromCmdLine);
end;
end;
function TPas2jsFilesCache.AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String;
begin
AddSrcUnitPaths(aValue,FromCmdLine,Result);
end;
function TPas2jsFilesCache.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out
RelPath: String): Boolean;
begin
Result:=Pas2jsFileUtils.TryCreateRelativePath(Filename, BaseDirectory, UsePointDirectory, RelPath);
end;
function TPas2jsFilesCache.FindIncludeFileName(const aFilename: string): String;
@ -2112,12 +1996,15 @@ end;
function TPas2jsFilesCache.FindCustomJSFileName(const aFilename: string): String;
Var
FN : String;
function SearchInDir(Dir: string): boolean;
var
CurFilename: String;
begin
Dir:=IncludeTrailingPathDelimiter(Dir);
CurFilename:=Dir+aFilename;
CurFilename:=Dir+FN;
Result:=FileExistsLogged(CurFilename);
if Result then
FindCustomJSFileName:=CurFilename;
@ -2127,18 +2014,18 @@ var
i: Integer;
begin
Result:='';
if FilenameIsAbsolute(aFilename) then
FN:=ResolveDots(aFileName);
if FilenameIsAbsolute(FN) then
begin
Result:=aFilename;
Result:=FN;
if not FileExistsLogged(Result) then
Result:='';
exit;
end;
if ExtractFilePath(aFilename)<>'' then
if ExtractFilePath(FN)<>'' then
begin
Result:=ExpandFileNamePJ(aFilename,BaseDirectory);
Result:=ExpandFileNamePJ(FN,BaseDirectory);
if not FileExistsLogged(Result) then
Result:='';
exit;
@ -2169,6 +2056,11 @@ begin
Log.LogMsgIgnoreFilter(nSearchingFileNotFound,[FormatPath(Filename)]);
end;
function TPas2jsFilesCache.GetOnReadDirectory: TReadDirectoryEvent;
begin
Result:=DirectoryCache.OnReadDirectory;
end;
function TPas2jsFilesCache.FileExistsILogged(var Filename: string): integer;
begin
Result:=DirectoryCache.FileExistsI(Filename);

88
packages/pastojs/src/pas2jsfileutils.pp
View File

@ -66,8 +66,6 @@ function GetEnvironmentVariablePJ(const EnvVar: string): String;
function GetNextDelimitedItem(const List: string; Delimiter: char;
var Position: integer): string;
procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
ReadBackslash: boolean = false);
type TChangeStamp = SizeInt;
const InvalidChangeStamp = low(TChangeStamp);
@ -732,92 +730,6 @@ begin
if Position<=length(List) then inc(Position); // skip Delimiter
end;
procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
ReadBackslash: boolean = false);
// split spaces, quotes are parsed as single parameter
// if ReadBackslash=true then \" is replaced to " and not treated as quote
// #0 is always end
type
TMode = (mNormal,mApostrophe,mQuote);
var
p: Integer;
Mode: TMode;
Param: String;
begin
p:=1;
while p<=length(Params) do
begin
// skip whitespace
while (p<=length(Params)) and (Params[p] in [' ',#9,#10,#13]) do inc(p);
if (p>length(Params)) or (Params[p]=#0) then
break;
// read param
Param:='';
Mode:=mNormal;
while p<=length(Params) do
begin
case Params[p] of
#0:
break;
'\':
begin
inc(p);
if ReadBackslash then
begin
// treat next character as normal character
if (p>length(Params)) or (Params[p]=#0) then
break;
if ord(Params[p])<128 then
begin
Param+=Params[p];
inc(p);
end else begin
// next character is already a normal character
end;
end else begin
// treat backslash as normal character
Param+='\';
end;
end;
'''':
begin
inc(p);
case Mode of
mNormal:
Mode:=mApostrophe;
mApostrophe:
Mode:=mNormal;
mQuote:
Param+='''';
end;
end;
'"':
begin
inc(p);
case Mode of
mNormal:
Mode:=mQuote;
mApostrophe:
Param+='"';
mQuote:
Mode:=mNormal;
end;
end;
' ',#9,#10,#13:
begin
if Mode=mNormal then break;
Param+=Params[p];
inc(p);
end;
else
Param+=Params[p];
inc(p);
end;
end;
//writeln('SplitCmdLineParams Param=#'+Param+'#');
ParamList.Add(Param);
end;
end;
procedure IncreaseChangeStamp(var Stamp: TChangeStamp);
begin

427
packages/pastojs/src/pas2jsfs.pp Normal file
View File

@ -0,0 +1,427 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
FileSystem abstraction layer for compiler.
Has only abstract classes with no actual implementation, so it does not actually
interacts with the filesystem.
See Pas2JSFileCache for an actual implementation.
}
unit pas2jsfs;
{$mode objfpc}{$H+}
{$I pas2js_defines.inc}
interface
uses
// No filesystem-dependent units here !
Classes, SysUtils, pscanner, fpjson;
const // Messages
nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s';
nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found';
nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found';
nDuplicateFileFound = 205; sDuplicateFileFound = 'Duplicate file found: "%s" and "%s"';
nCustomJSFileNotFound = 206; sCustomJSFileNotFound = 'custom JS file not found: "%s"';
nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
Type
// Forward definitions
EPas2jsFS = Class(Exception);
TPas2jsFile = class;
TSourceLineReader = class;
TPas2jsFSResolver = class;
TPas2JSFS = Class;
{ TSourceLineReader }
TSourceLineReader = class(TLineReader)
private
FIsEOF: boolean;
FLineNumber: integer;
FSource: string;
FSrcPos: integer;
Protected
Procedure IncLineNumber; virtual;
property Source: string read FSource;
property SrcPos: integer read FSrcPos;
public
Constructor Create(Const aFileName, aSource : String); overload;
function IsEOF: Boolean; override;
function ReadLine: string; override;
property LineNumber: integer read FLineNumber;
end;
TP2jsFSOption = (
caoShowFullFilenames,
caoShowTriedUsedFiles,
caoSearchLikeFPC,
caoStrictFileCase
);
TP2jsFSOptions = set of TP2jsFSOption;
TKeyCompareType = (kcFilename,kcUnitName);
{ TPas2JSFS }
TPas2JSFS = Class
Private
FOptions: TP2jsFSOptions;
FReadLineCounter: SizeInt;
FDefaultOutputPath: string;
FUnitOutputPath: string;
procedure SetOptionFromIndex(AIndex: Integer; AValue: boolean);
procedure SetDefaultOutputPath(AValue: string);
procedure SetUnitOutputPath(AValue: string);
Protected
// Not to be overridden
procedure SetOption(Flag: TP2jsFSOption; Enable: boolean);
Function OptionIsSet(Index : Integer) : Boolean;
Protected
// Protected Abstract. Must be overridden
function FindSourceFileName(const aFilename: string): String; virtual; abstract;
Public
// Public Abstract. Must be overridden
function FindIncludeFileName(const aFilename: string): String; virtual; abstract;
function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; virtual; abstract;
Function FileExists(Const aFileName : String) : Boolean; virtual; abstract;
function FindUnitJSFileName(const aUnitFilename: string): String; virtual; abstract;
function FindCustomJSFileName(const aFilename: string): String; virtual; abstract;
function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; virtual; abstract;
procedure SaveToFile(ms: TFPJSStream; Filename: string); virtual; abstract;
Function PCUExists(var aFileName : string) : Boolean; virtual;
procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); virtual;
Public
// Public, may be overridden
Function SameFileName(Const File1,File2 : String) : Boolean; virtual;
Function File1IsNewer(Const File1,File2 : String) : Boolean; virtual;
function ExpandDirectory(const Filename: string): string; virtual;
function ExpandFileName(const Filename: string): string; virtual;
function ExpandExecutable(const Filename: string): string; virtual;
Function FormatPath(Const aFileName : string) : String; virtual;
Function DirectoryExists(Const aDirectory : string) : boolean; virtual;
function TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String): Boolean; virtual;
Procedure WriteFoldersAndSearchPaths; virtual;
function CreateResolver: TPas2jsFSResolver; virtual;
// On success, return '', On error, return error message.
Function AddForeignUnitPath(Const aValue : String; FromCmdLine : Boolean) : String; virtual;
Function HandleOptionPaths(C : Char; aValue : String; FromCmdLine : Boolean) : String; virtual;
Public
Constructor Create; virtual;
Procedure Reset; virtual;
Procedure IncReadLineCounter;
property ReadLineCounter: SizeInt read FReadLineCounter write FReadLineCounter;
property Options: TP2jsFSOptions read FOptions write FOptions;
property ShowFullPaths: boolean Index 0 Read OptionIsSet Write SetOptionFromIndex;
property ShowTriedUsedFiles: boolean Index 1 read OptionIsSet Write SetOptionFromIndex;
property SearchLikeFPC: boolean index 2 read OptionIsSet Write SetOptionFromIndex;
Property StrictFileCase : Boolean Index 3 Read OptionIsSet Write SetOptionFromIndex;
property MainOutputPath: string read FDefaultOutputPath write SetDefaultOutputPath; // includes trailing pathdelim
property UnitOutputPath: string read FUnitOutputPath write SetUnitOutputPath; // includes trailing pathdelim
end;
{ TPas2jsFile }
TPas2jsFile = class
private
FFilename: string;
FFS: TPas2JSFS;
FSource: string;
Protected
Procedure SetSource(aSource : String);
public
constructor Create(aFS: TPas2jsFS; const aFilename: string);
function CreateLineReader(RaiseOnError: boolean): TSourceLineReader; virtual; abstract;
function Load(RaiseOnError: boolean; Binary: boolean): boolean; virtual; abstract;
property Source: string read FSource; // UTF-8 without BOM or Binary
Property FS : TPas2JSFS Read FFS;
property Filename: string read FFilename;
end;
{ TPas2jsFSResolver }
TPas2jsFSResolver = class({$IFDEF HASFILESYSTEM}TFileResolver{$ELSE}TBaseFileResolver{$ENDIF})
private
FFS: TPas2jsFS;
public
constructor Create(aFS : TPas2jsFS); reintroduce;
// Redirect all calls to FS.
function FindIncludeFileName(const aFilename: string): String; override;
function FindIncludeFile(const aFilename: string): TLineReader; override;
function FindSourceFile(const aFilename: string): TLineReader; override;
property FS: TPas2jsFS read FFS;
end;
Const
p2jsfcoCaption: array[TP2jsFSOption] of string = (
// only used by experts, no need for resourcestrings
'Show full filenames',
'Show tried/used files',
'Search files like FPC',
'Strict file case'
);
// 'Combine all JavaScript into main file',
EncodingBinary = 'Binary';
DefaultPas2jsFSOptions = [];
implementation
// No filesystem-dependent units here !
{ TPas2JSFS }
procedure TPas2JSFS.SetOptionFromIndex(AIndex: Integer; AValue: boolean);
begin
SetOption(TP2jsFSOption(aIndex),aValue);
end;
procedure TPas2JSFS.SetOption(Flag: TP2jsFSOption; Enable: boolean);
begin
if Enable then
Include(FOptions,Flag)
else
Exclude(FOptions,Flag);
end;
function TPas2JSFS.OPtionIsSet(Index: Integer): Boolean;
begin
Result:=TP2jsFSOption(Index) in FOptions;
end;
function TPas2JSFS.PCUExists(var aFileName: string): Boolean;
begin
Result:=Self.FileExists(aFileName);
end;
procedure TPas2JSFS.GetPCUDirs(aList: TStrings; Const aBaseDir : String);
begin
if UnitOutputPath<>'' then
Alist.Add(UnitOutputPath);
Alist.Add(aBaseDir);
end;
function TPas2JSFS.SameFileName(const File1, File2: String): Boolean;
begin
Result:=CompareText(File1,File2)=0;
end;
function TPas2JSFS.File1IsNewer(const File1, File2: String): Boolean;
begin
Result:=False;
end;
function TPas2JSFS.ExpandDirectory(const Filename : String): string;
begin
Result:=FileName;
end;
function TPas2JSFS.ExpandFileName(const Filename: string): string;
begin
Result:=FileName;
end;
function TPas2JSFS.ExpandExecutable(const Filename : string): string;
begin
Result:=FileName
end;
function TPas2JSFS.FormatPath(const aFileName: string): String;
begin
Result:=aFileName;
end;
function TPas2JSFS.DirectoryExists(const aDirectory: string): boolean;
begin
Result:=False;
end;
function TPas2JSFS.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String
): Boolean;
begin
Result:=True;
RelPath:=FileName;
end;
procedure TPas2JSFS.WriteFoldersAndSearchPaths;
begin
// Do nothing
end;
function TPas2JSFS.CreateResolver: TPas2jsFSResolver;
begin
Result:=TPas2jsFSResolver.Create(Self);
end;
function TPas2JSFS.AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String;
begin
Result:='';
end;
function TPas2JSFS.HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String;
begin
Result:='Invalid parameter : -F'+C+aValue;
end;
constructor TPas2JSFS.Create;
begin
FOptions:=DefaultPas2jsFSOptions;
end;
procedure TPas2JSFS.Reset;
begin
FReadLineCounter:=0;
FUnitOutputPath:='';
FDefaultOutputPath:='';
end;
procedure TPas2JSFS.IncReadLineCounter;
begin
Inc(FReadLineCounter);
end;
procedure TPas2jsFS.SetDefaultOutputPath(AValue: string);
begin
AValue:=ExpandDirectory(AValue);
if FDefaultOutputPath=AValue then Exit;
FDefaultOutputPath:=AValue;
end;
procedure TPas2jsFS.SetUnitOutputPath(AValue: string);
begin
AValue:=ExpandDirectory(AValue);
if FUnitOutputPath=AValue then Exit;
FUnitOutputPath:=AValue;
end;
{ TPas2jsFile }
procedure TPas2jsFile.SetSource(aSource: String);
begin
FSource:=ASource;
end;
constructor TPas2jsFile.Create(aFS: TPas2jsFS; const aFilename: string);
begin
FFS:=aFS;
FFileName:=aFileName;
end;
procedure TSourceLineReader.IncLineNumber;
begin
inc(FLineNumber);
end;
Constructor TSourceLineReader.Create(Const aFileName, aSource : String);
begin
Inherited Create(aFileName);
FSource:=aSource;
FSrcPos:=1;
FIsEOF:=FSource='';
end;
function TSourceLineReader.IsEOF: Boolean;
begin
Result:=FIsEOF;
end;
function TSourceLineReader.ReadLine: string;
var
S: string;
p, SrcLen: integer;
procedure GetLine;
var
l: SizeInt;
begin
l:=p-FSrcPos;
Result:=copy(S,FSrcPos,l);
FSrcPos:=p;
IncLineNumber;
//writeln('GetLine "',Result,'"');
end;
begin
if FIsEOF then exit('');
S:=Source;
SrcLen:=length(S);
p:=FSrcPos;
while p<=SrcLen do
case S[p] of
#10,#13:
begin
GetLine;
inc(p);
if (p<=SrcLen) and (S[p] in [#10,#13]) and (S[p]<>S[p-1]) then
inc(p);
if p>SrcLen then
FIsEOF:=true;
FSrcPos:=p;
exit;
end;
else
inc(p);
end;
FIsEOF:=true;
GetLine;
end;
function TPas2jsFSResolver.FindIncludeFile(const aFilename: string): TLineReader;
var
Filename: String;
begin
Result:=nil;
Filename:=FS.FindIncludeFileName(aFilename);
if Filename='' then exit;
try
Result:=FindSourceFile(Filename);
except
// error is shown in the scanner, which has the context information
end;
end;
constructor TPas2jsFSResolver.Create(aFS: TPas2jsFS);
begin
FFS:=aFS;
end;
function TPas2jsFSResolver.FindIncludeFileName(const aFilename: string): String;
begin
Result:=FS.FindIncludeFileName(aFilename);
end;
function TPas2jsFSResolver.FindSourceFile(const aFilename: string): TLineReader;
var
CurFilename: String;
begin
CurFilename:=FS.FindSourceFileName(aFileName);
Result:=FS.LoadFile(CurFilename).CreateLineReader(false);
end;
end.

164
packages/pastojs/src/pas2jsfscompiler.pp Normal file
View File

@ -0,0 +1,164 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
FileSystem aware compiler descendent. No support for PCU.
}
unit pas2jsfscompiler;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, pastree, pas2jscompiler,
pas2jsfs, pas2jsfilecache, pasuseanalyzer;
Type
TPas2jsFSCompiler = Class(TPas2JSCompiler)
private
function GetFileCache: TPas2jsFilesCache;
function OnMacroEnv(Sender: TObject; var Params: string; Lvl: integer): boolean;
Public
Procedure SetWorkingDir(const aDir: String); override;
function CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet; override;
Function CreateFS : TPas2JSFS; override;
Procedure InitParamMacros; override;
Property FileCache : TPas2jsFilesCache Read GetFileCache;
end;
implementation
uses fppas2js, pscanner, pas2jsfileutils;
{$IFDEF PAS2JS}
function Pas2jsCompilerFile_FilenameToKeyName(Item: Pointer): String;
var
aFile: TPas2jsCompilerFile absolute Item;
begin
Result:=FilenameToKey(aFile.PasFilename);
end;
function PtrUnitnameToKeyName(Item: Pointer): String;
var
aUnitName: string absolute Item;
begin
Result:=LowerCase(aUnitName);
end;
function Pas2jsCompilerFile_UnitnameToKeyName(Item: Pointer): String;
var
aFile: TPas2jsCompilerFile absolute Item;
begin
Result:=LowerCase(aFile.PasUnitName);
end;
{$ELSE}
function CompareCompilerFilesPasFile(Item1, Item2: Pointer): integer;
var
File1: TPas2JSCompilerFile absolute Item1;
File2: TPas2JSCompilerFile absolute Item2;
begin
Result:=CompareFilenames(File1.PasFilename,File2.PasFilename);
end;
function CompareFileAndCompilerFilePasFile(Filename, Item: Pointer): integer;
var
aFile: TPas2JSCompilerFile absolute Item;
aFilename: String;
begin
aFilename:=AnsiString(Filename);
Result:=CompareFilenames(aFilename,aFile.PasFilename);
end;
function CompareCompilerFilesPasUnitname(Item1, Item2: Pointer): integer;
var
File1: TPas2JSCompilerFile absolute Item1;
File2: TPas2JSCompilerFile absolute Item2;
begin
Result:=CompareText(File1.PasUnitName,File2.PasUnitName);
end;
function CompareUnitnameAndCompilerFile(TheUnitname, Item: Pointer): integer;
var
aFile: TPas2JSCompilerFile absolute Item;
anUnitname: String;
begin
anUnitname:=AnsiString(TheUnitname);
Result:=CompareText(anUnitname,aFile.PasUnitName);
end;
{$ENDIF}
function TPas2jsFSCompiler.CreateFS: TPas2JSFS;
Var
C : TPas2jsFilesCache;
begin
C:=TPas2jsFilesCache.Create(Log);
C.BaseDirectory:=GetCurrentDirPJ;
Result:=C;
end;
function TPas2jsFSCompiler.GetFileCache: TPas2jsFilesCache;
begin
Result:=FS as TPas2jsFilesCache;
end;
function TPas2jsFSCompiler.OnMacroEnv(Sender: TObject; var Params: string; Lvl: integer): boolean;
begin
if Lvl=0 then ;
Params:=GetEnvironmentVariablePJ(Params);
Result:=true;
end;
procedure TPas2jsFSCompiler.SetWorkingDir(const aDir: String);
begin
inherited SetWorkingDir(aDir);
FileCache.BaseDirectory:=aDir;
end;
function TPas2jsFSCompiler.CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet;
begin
Case keyType of
kcFileName:
Result:=TPasAnalyzerKeySet.Create(
{$IFDEF Pas2js}
@Pas2jsCompilerFile_FilenameToKeyName,@PtrFilenameToKeyName
{$ELSE}
@CompareCompilerFilesPasFile,@CompareFileAndCompilerFilePasFile
{$ENDIF});
kcUnitName:
Result:=TPasAnalyzerKeySet.Create(
{$IFDEF Pas2js}
@Pas2jsCompilerFile_UnitnameToKeyName,@PtrUnitnameToKeyName
{$ELSE}
@CompareCompilerFilesPasUnitname,@CompareUnitnameAndCompilerFile
{$ENDIF});
else
Raise EPas2jsFileCache.CreateFmt('Internal Unknown key type: %d',[Ord(KeyType)]);
end;
end;
procedure TPas2jsFSCompiler.InitParamMacros;
begin
inherited InitParamMacros;
ParamMacros.AddFunction('Env','environment variable, e.g. $Env(HOME)',@OnMacroEnv,true);
end;
end.

10
packages/pastojs/src/pas2jslibcompiler.pp
View File

@ -2,7 +2,7 @@
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
Pascal to Javascript converter class. Library version
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -21,7 +21,7 @@ unit pas2jslibcompiler;
interface
uses
SysUtils, Classes, FPPJsSrcMap, Pas2jsFileCache, Pas2jsCompiler;
SysUtils, Classes, FPPJsSrcMap, Pas2jsFileCache, Pas2JSCompiler, Pas2jsPCUCompiler, pas2jscompilercfg, pas2jscompilerpp;
{ ---------------------------------------------------------------------
Compiler descendant, usable in library
@ -44,7 +44,7 @@ Type
{ TLibraryPas2JSCompiler }
TLibraryPas2JSCompiler = Class(TPas2JSCompiler)
TLibraryPas2JSCompiler = Class(TPas2JSPCUCompiler)
private
FLastError: String;
FLastErrorClass: String;
@ -181,7 +181,9 @@ begin
Log.OnLog:=@DoLibraryLog;
FileCache.OnReadFile:=@ReadFile;
FReadBufferLen:=DefaultReadBufferSize;
FileCache.DirectoryCache.OnReadDirectory:=@ReadDirectory;
FileCache.OnReadDirectory:=@ReadDirectory;
ConfigSupport:=TPas2JSFileConfigSupport.Create(Self);
PostProcessorSupport:=TPas2JSFSPostProcessorSupport.Create(Self);
end;
procedure TLibraryPas2JSCompiler.DoLibraryLog(Sender: TObject; const Msg: String);

69
packages/pastojs/src/pas2jslogger.pp
View File

@ -28,10 +28,13 @@ interface
uses
{$IFDEF Pas2JS}
JS, NodeJSFS,
JS,
{$ENDIF}
Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson,
Pas2jsFileUtils;
pas2jsutils,
{$IFDEF HASFILESYSTEM}
pas2jsfileutils,
{$ENDIF}
Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson;
const
ExitCodeErrorInternal = 1; // internal error
@ -95,6 +98,16 @@ type
TPas2jsLogEvent = Procedure (Sender : TObject; Const Msg : String) Of Object;
{ TConsoleFileWriter }
TConsoleFileWriter = Class(TTextWriter)
Public
Constructor Create(aFileName : String); reintroduce;
Function DoWrite(Const S : TJSWriterString) : Integer; override;
Procedure Flush;
end;
{ TPas2jsLogger }
TPas2jsLogger = class
@ -111,7 +124,7 @@ type
FMsg: TFPList; // list of TPas2jsMessage
FOnFormatPath: TPScannerFormatPathEvent;
FOnLog: TPas2jsLogEvent;
FOutputFile: TFileWriter;
FOutputFile: TTextWriter; // TFileWriter;
FOutputFilename: string;
FShowMsgNumbers: boolean;
FShowMsgTypes: TMessageTypes;
@ -129,6 +142,9 @@ type
procedure SetSorted(AValue: boolean);
procedure DoLogRaw(const Msg: string; SkipEncoding : Boolean);
function Concatenate(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
Protected
// so it can be overridden
function CreateTextWriter(const aFileName: string): TTextWriter; virtual;
public
constructor Create;
destructor Destroy; override;
@ -484,6 +500,27 @@ begin
end;
end;
{ TConsoleFileWriter }
constructor TConsoleFileWriter.Create(aFileName: String);
begin
Inherited Create;
Write('Opening console log: '+aFileName);
end;
Function TConsoleFileWriter.DoWrite(Const S : TJSWriterString) : Integer;
begin
Result:=Length(S);
Writeln(S);
end;
procedure TConsoleFileWriter.FLush;
begin
end;
{$IFDEF Pas2JS}
{ TPas2jsFileStream }
@ -1017,14 +1054,26 @@ begin
end;
end;
Function TPas2jsLogger.CreateTextWriter(const aFileName : string) : TTextWriter;
begin
{$IFDEF HASFILESYSTEM}
Result:=TFileWriter.Create(aFilename);
{$ELSE}
Result:=TConsoleFileWriter.Create(aFileName);
{$ENDIF}
end;
procedure TPas2jsLogger.OpenOutputFile;
begin
{$IFDEF HASFILESYSTEM}
if FOutputFile<>nil then exit;
if OutputFilename='' then
raise Exception.Create('Log has empty OutputFilename');
if DirectoryExists(OutputFilename) then
if DirectoryExists(OutputFilename) then
raise Exception.Create('Log is directory: "'+OutputFilename+'"');
FOutputFile:=TFileWriter.Create(OutputFilename);
{$ENDIF}
FOutputFile:=CreateTextWriter(OutputFileName);
{$IFDEF FPC_HAS_CPSTRING}
if (Encoding='') or (Encoding='utf8') then
FOutputFile.Write(UTF8BOM);
@ -1033,14 +1082,16 @@ end;
procedure TPas2jsLogger.Flush;
begin
if FOutputFile<>nil then
FOutputFile.Flush;
{$IFDEF HASFILESYSTEM}
if Assigned(FOutputFile) and (FoutputFile is TFileWriter) then
TFileWriter(FOutputFile).Flush;
{$ENDIF}
end;
procedure TPas2jsLogger.CloseOutputFile;
begin
if FOutputFile=nil then exit;
FOutputFile.Flush;
Flush;
FreeAndNil(FOutputFile);
end;

93
packages/pastojs/src/pas2jspcucompiler.pp
View File

@ -1,3 +1,21 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Michael Van Canneyt
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
FileSystem aware compiler descendent with support for PCU files.
}
unit pas2jspcucompiler;
{$mode objfpc}{$H+}
@ -11,11 +29,11 @@ unit pas2jspcucompiler;
interface
uses
Classes, SysUtils, pastree, pas2jscompiler, Pas2JsFiler;
SysUtils,Classes,
pastree,
pas2jscompiler, pas2jsfs, pas2jsfscompiler, Pas2JsFiler;
Type
{ TFilerPCUSupport }
TFilerPCUSupport = Class(TPCUSupport)
Private
// This is the format that will be written.
@ -46,15 +64,17 @@ Type
property PrecompileInitialFlags: TPCUInitialFlags read FPrecompileInitialFlags;
end;
{ TPas2jsPCUCompiler }
{ TPas2jsPCUCompilerFile }
TPas2jsPCUCompilerFile = Class(TPas2jsCompilerFile)
Function CreatePCUSupport: TPCUSupport; override;
end;
TPas2jsPCUCompiler = Class(TPas2JSCompiler)
{ TPas2jsPCUCompiler }
TPas2jsPCUCompiler = Class(TPas2JSFSCompiler)
Private
FPrecompileFormat : TPas2JSPrecompileFormat;
Protected
procedure WritePrecompiledFormats; override;
@ -64,7 +84,11 @@ Type
implementation
uses fppas2js, pscanner, pas2jslogger, pas2jsfilecache, pasresolveeval, jstree, pas2jsfileutils;
uses fppas2js, pscanner, pas2jslogger, pasresolveeval, jstree, pas2jsfileutils;
{$IFDEF HASPAS2JSFILER}
{ ---------------------------------------------------------------------
TFilerPCUSupport
@ -148,7 +172,7 @@ end;
procedure TFilerPCUSupport.CreatePCUReader;
var
aFile: TPas2jsCachedFile;
aFile: TPas2jsFile;
s: String;
begin
if MyFile.PCUFilename='' then
@ -162,7 +186,7 @@ begin
if MyFile.ShowDebug then
MyFile.Log.LogMsg(nParsingFile,[QuoteStr(MyFile.PCUFilename)]);
aFile:=Compiler.FileCache.LoadFile(MyFile.PCUFilename,true);
aFile:=Compiler.FS.LoadFile(MyFile.PCUFilename,true);
if aFile=nil then
RaiseInternalError(20180312145941,MyFile.PCUFilename);
FPCUReaderStream:=TMemoryStream.Create;
@ -199,7 +223,7 @@ function TFilerPCUSupport.FindPCU(const UseUnitName: string; out aFormat: TPas2
CurFormat:=PrecompileFormats[i];
if not CurFormat.Enabled then continue;
Filename:=DirPath+UseUnitName+'.'+CurFormat.Ext;
if Compiler.FileCache.SearchLowUpCase(Filename) then
if Compiler.FS.PCUExists(Filename) then
begin
FindPCU:=Filename;
aFormat:=CurFormat;
@ -210,23 +234,20 @@ function TFilerPCUSupport.FindPCU(const UseUnitName: string; out aFormat: TPas2
end;
var
Cache: TPas2jsFilesCache;
L : TstringList;
i: Integer;
begin
Result:='';
aFormat:=nil;
Cache:=Compiler.FileCache;
// search in output directory
if Cache.UnitOutputPath<>'' then
if SearchInDir(Cache.UnitOutputPath) then exit;
// then in BaseDirectory
if SearchInDir(MyFile.FileResolver.BaseDirectory) then exit;
// finally search in unit paths
for i:=0 to Cache.UnitPaths.Count-1 do
if SearchInDir(Cache.UnitPaths[i]) then exit;
L:=TstringList.Create;
try
Compiler.FS.GetPCUDirs(L,MyFile.FileResolver.BaseDirectory);
for i:=0 to L.Count-1 do
if SearchInDir(L[i]) then exit;
finally
L.Free;
end;
end;
function TFilerPCUSupport.OnWriterIsElementUsed(Sender: TObject;
@ -269,8 +290,8 @@ begin
// Determine output filename
FN:=ExtractFilenameOnly(MyFile.PasFilename)+'.'+FPCUFormat.Ext;
if Compiler.FileCache.UnitOutputPath<>'' then
FN:=Compiler.FileCache.UnitOutputPath+FN
if Compiler.FS.UnitOutputPath<>'' then
FN:=Compiler.FS.UnitOutputPath+FN
else
FN:=ExtractFilePath(MyFile.PasFilename)+FN;
// Set as our filename
@ -302,30 +323,30 @@ begin
writeln('TPas2jsCompilerFile.WritePCU precompiled ',MyFile.PCUFilename);
{$ENDIF}
MyFile.Log.LogMsg(nWritingFile,[QuoteStr(Compiler.FileCache.FormatPath(MyFile.PCUFilename))],'',0,0,
MyFile.Log.LogMsg(nWritingFile,[QuoteStr(Compiler.FS.FormatPath(MyFile.PCUFilename))],'',0,0,
not (coShowLineNumbers in Compiler.Options));
// check output directory
DestDir:=ChompPathDelim(ExtractFilePath(MyFile.PCUFilename));
if (DestDir<>'') and not Compiler.FileCache.DirectoryExists(DestDir) then
if (DestDir<>'') and not Compiler.FS.DirectoryExists(DestDir) then
begin
{$IFDEF REALLYVERBOSE}
writeln('TPas2jsCompilerFile.WritePCU output dir not found "',DestDir,'"');
{$ENDIF}
MyFile.Log.LogMsg(nOutputDirectoryNotFound,[QuoteStr(Compiler.FileCache.FormatPath(DestDir))]);
MyFile.Log.LogMsg(nOutputDirectoryNotFound,[QuoteStr(Compiler.FS.FormatPath(DestDir))]);
Compiler.Terminate(ExitCodeFileNotFound);
end;
if Compiler.FileCache.DirectoryExists(MyFile.PCUFilename) then
if Compiler.FS.DirectoryExists(MyFile.PCUFilename) then
begin
{$IFDEF REALLYVERBOSE}
writeln('TPas2jsCompilerFile.WritePCU file is folder "',DestDir,'"');
{$ENDIF}
MyFile.Log.LogMsg(nFileIsFolder,[QuoteStr(Compiler.FileCache.FormatPath(MyFile.PCUFilename))]);
MyFile.Log.LogMsg(nFileIsFolder,[QuoteStr(Compiler.FS.FormatPath(MyFile.PCUFilename))]);
Compiler.Terminate(ExitCodeWriteError);
end;
ms.Position:=0;
Compiler.FileCache.SaveToFile(ms,MyFile.PCUFilename);
Compiler.FS.SaveToFile(ms,MyFile.PCUFilename);
{$IFDEF REALLYVERBOSE}
writeln('TPas2jsCompilerFile.WritePCU written ',MyFile.PCUFilename);
{$ENDIF}
@ -339,11 +360,11 @@ end;
procedure TFilerPCUSupport.OnFilerGetSrc(Sender: TObject; aFilename: string;
out p: PChar; out Count: integer);
var
SrcFile: TPas2jsCachedFile;
SrcFile: TPas2jsFile;
begin
if Sender=nil then
RaiseInternalError(20180311135558,aFilename);
SrcFile:=MyFile.Compiler.FileCache.LoadFile(aFilename);
SrcFile:=MyFile.Compiler.FS.LoadFile(aFilename);
if SrcFile=nil then
RaiseInternalError(20180311135329,aFilename);
p:=PChar(SrcFile.Source);
@ -370,6 +391,8 @@ end;
{ TPas2jsPCUCompiler }
procedure TPas2jsPCUCompiler.WritePrecompiledFormats;
Var
@ -410,6 +433,8 @@ begin
ParamFatal('invalid precompile output format (-JU) "'+Value+'"');
end;
{ TPas2jsPCUCompilerFile }
function TPas2jsPCUCompilerFile.CreatePCUSupport: TPCUSupport;
@ -425,7 +450,7 @@ begin
else
Result:=Nil;
end;
{$ENDIF}
end.

430
packages/pastojs/src/pas2jsutils.pp Normal file
View File

@ -0,0 +1,430 @@
unit pas2jsutils;
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Mattias Gaertner mattias@freepascal.org
Pascal to Javascript converter class.
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.
**********************************************************************
Abstract:
Utility routines that do not need a filesystem or OS functionality.
Filesystem-specific things should go to pas2jsfileutils instead.
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
function ChompPathDelim(const Path: string): string;
function GetNextDelimitedItem(const List: string; Delimiter: char;
var Position: integer): string;
type
TChangeStamp = SizeInt;
const
InvalidChangeStamp = low(TChangeStamp);
Function IncreaseChangeStamp(Stamp: TChangeStamp) : TChangeStamp;
const
EncodingUTF8 = 'UTF-8';
EncodingSystem = 'System';
function NormalizeEncoding(const Encoding: string): string;
function IsASCII(const s: string): boolean; inline;
{$IFDEF FPC_HAS_CPSTRING}
const
UTF8BOM = #$EF#$BB#$BF;
function UTF8CharacterStrictLength(P: PChar): integer;
function UTF8ToUTF16(const s: string): UnicodeString;
function UTF16ToUTF8(const s: UnicodeString): string;
{$ENDIF FPC_HAS_CPSTRING}
function IsNonUTF8System: boolean;// true if system encoding is not UTF-8
{$IFDEF Windows}
// AConsole - If false, it is the general system encoding,
// if true, it is the console encoding
function GetWindowsEncoding(AConsole: Boolean = False): string;
{$ENDIF}
{$IF defined(Unix) and not defined(Darwin)}
function GetUnixEncoding: string;
{$ENDIF}
Function NonUTF8System: boolean;
function GetDefaultTextEncoding: string;
procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
ReadBackslash: boolean = false);
implementation
{$IFDEF Windows}
uses Windows;
{$ENDIF}
Var
{$IFDEF Unix}
{$IFNDEF Darwin}
Lang: string = '';
{$ENDIF}
{$ENDIF}
EncodingValid: boolean = false;
DefaultTextEncoding: string = EncodingSystem;
gNonUTF8System : Boolean = {$IFDEF FPC_HAS_CPSTRING}false{$ELSE}true{$ENDIF};
Function NonUTF8System: boolean;
begin
Result:=gNonUTF8System;
end;
function GetNextDelimitedItem(const List: string; Delimiter: char;
var Position: integer): string;
var
StartPos: Integer;
begin
StartPos:=Position;
while (Position<=length(List)) and (List[Position]<>Delimiter) do
inc(Position);
Result:=copy(List,StartPos,Position-StartPos);
if Position<=length(List) then inc(Position); // skip Delimiter
end;
function IncreaseChangeStamp(Stamp: TChangeStamp): TChangeStamp;
begin
if Stamp<High(TChangeStamp) then
Result:=Stamp+1
else
Result:=InvalidChangeStamp+1;
end;
function ChompPathDelim(const Path: string): string;
var
Len, MinLen: Integer;
begin
Result:=Path;
if Path = '' then
exit;
Len:=length(Result);
if (Result[1] in AllowDirectorySeparators) then
begin
MinLen := 1;
{$IFDEF HasUNCPaths}
if (Len >= 2) and (Result[2] in AllowDirectorySeparators) then
MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a'
{$ENDIF}
{$IFDEF Pas2js}
if (Len >= 2) and (Result[2]=Result[1]) and (PathDelim='\') then
MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a'
{$ENDIF}
end
else begin
MinLen := 0;
{$IFdef MSWindows}
if (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z']) and
(Result[2] = ':') and (Result[3] in AllowDirectorySeparators)
then
MinLen := 3;
{$ENDIF}
{$IFdef Pas2js}
if (PathDelim='\')
and (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z'])
and (Result[2] = ':') and (Result[3] in AllowDirectorySeparators)
then
MinLen := 3;
{$ENDIF}
end;
while (Len > MinLen) and (Result[Len] in AllowDirectorySeparators) do dec(Len);
if Len<length(Result) then
SetLength(Result,Len);
end;
function NormalizeEncoding(const Encoding: string): string;
var
i: Integer;
begin
Result:=LowerCase(Encoding);
for i:=length(Result) downto 1 do
if Result[i]='-' then Delete(Result,i,1);
end;
{$IFDEF WINDOWS}
function GetWindowsEncoding(AConsole: Boolean = False): string;
var
cp : UINT;
{$IFDEF WinCE}
// CP_UTF8 is missing in the windows unit of the Windows CE RTL
const
CP_UTF8 = 65001;
{$ENDIF}
begin
if AConsole then cp := GetOEMCP
else cp := GetACP;
case cp of
CP_UTF8: Result := EncodingUTF8;
else
Result:='cp'+IntToStr(cp);
end;
end;
{$ENDIF}
function IsASCII(const s: string): boolean; inline;
{$IFDEF Pas2js}
var
i: Integer;
begin
for i:=1 to length(s) do
if s[i]>#127 then exit(false);
Result:=true;
end;
{$ELSE}
var
p: PChar;
begin
if s='' then exit(true);
p:=PChar(s);
repeat
case p^ of
#0: if p-PChar(s)=length(s) then exit(true);
#128..#255: exit(false);
end;
inc(p);
until false;
end;
{$ENDIF}
{$IFDEF FPC_HAS_CPSTRING}
function UTF8CharacterStrictLength(P: PChar): integer;
begin
if p=nil then exit(0);
if ord(p^)<%10000000 then
begin
// regular single byte character
exit(1);
end
else if ord(p^)<%11000000 then
begin
// invalid single byte character
exit(0);
end
else if ((ord(p^) and %11100000) = %11000000) then
begin
// should be 2 byte character
if (ord(p[1]) and %11000000) = %10000000 then
exit(2)
else
exit(0);
end
else if ((ord(p^) and %11110000) = %11100000) then
begin
// should be 3 byte character
if ((ord(p[1]) and %11000000) = %10000000)
and ((ord(p[2]) and %11000000) = %10000000) then
exit(3)
else
exit(0);
end
else if ((ord(p^) and %11111000) = %11110000) then
begin
// should be 4 byte character
if ((ord(p[1]) and %11000000) = %10000000)
and ((ord(p[2]) and %11000000) = %10000000)
and ((ord(p[3]) and %11000000) = %10000000) then
exit(4)
else
exit(0);
end else
exit(0);
end;
function UTF8ToUTF16(const s: string): UnicodeString;
begin
Result:=UTF8Decode(s);
end;
function UTF16ToUTF8(const s: UnicodeString): string;
begin
if s='' then exit('');
Result:=UTF8Encode(s);
// prevent UTF8 codepage appear in the strings - we don't need codepage
// conversion magic
SetCodePage(RawByteString(Result), CP_ACP, False);
end;
{$ENDIF}
function IsNonUTF8System: boolean;
begin
Result:=NonUTF8System;
end;
{$IFDEF UNIX}
{$IFNDEF Darwin}
function GetUnixEncoding: string;
var
i: integer;
begin
Result:=EncodingSystem;
i:=pos('.',Lang);
if (i>0) and (i<=length(Lang)) then
Result:=copy(Lang,i+1,length(Lang)-i);
end;
{$ENDIF}
{$ENDIF}
function GetDefaultTextEncoding: string;
begin
if EncodingValid then
begin
Result:=DefaultTextEncoding;
exit;
end;
{$IFDEF Pas2js}
Result:=EncodingUTF8;
{$ELSE}
{$IFDEF Windows}
Result:=GetWindowsEncoding;
{$ELSE}
{$IFDEF Darwin}
Result:=EncodingUTF8;
{$ELSE}
// unix
Lang := GetEnvironmentVariable('LC_ALL');
if Lang='' then
begin
Lang := GetEnvironmentVariable('LC_MESSAGES');
if Lang='' then
Lang := GetEnvironmentVariable('LANG');
end;
Result:=GetUnixEncoding;
{$ENDIF}
{$ENDIF}
{$ENDIF}
Result:=NormalizeEncoding(Result);
DefaultTextEncoding:=Result;
EncodingValid:=true;
end;
procedure InternalInit;
begin
{$IFDEF FPC_HAS_CPSTRING}
SetMultiByteConversionCodePage(CP_UTF8);
// SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows
SetMultiByteRTLFileSystemCodePage(CP_UTF8);
GetDefaultTextEncoding;
{$IFDEF Windows}
gNonUTF8System:=true;
{$ELSE}
gNonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0;
{$ENDIF}
{$ENDIF}
end;
procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
ReadBackslash: boolean = false);
// split spaces, quotes are parsed as single parameter
// if ReadBackslash=true then \" is replaced to " and not treated as quote
// #0 is always end
type
TMode = (mNormal,mApostrophe,mQuote);
var
p: Integer;
Mode: TMode;
Param: String;
begin
p:=1;
while p<=length(Params) do
begin
// skip whitespace
while (p<=length(Params)) and (Params[p] in [' ',#9,#10,#13]) do inc(p);
if (p>length(Params)) or (Params[p]=#0) then
break;
// read param
Param:='';
Mode:=mNormal;
while p<=length(Params) do
begin
case Params[p] of
#0:
break;
'\':
begin
inc(p);
if ReadBackslash then
begin
// treat next character as normal character
if (p>length(Params)) or (Params[p]=#0) then
break;
if ord(Params[p])<128 then
begin
Param+=Params[p];
inc(p);
end else begin
// next character is already a normal character
end;
end else begin
// treat backslash as normal character
Param+='\';
end;
end;
'''':
begin
inc(p);
case Mode of
mNormal:
Mode:=mApostrophe;
mApostrophe:
Mode:=mNormal;
mQuote:
Param+='''';
end;
end;
'"':
begin
inc(p);
case Mode of
mNormal:
Mode:=mQuote;
mApostrophe:
Param+='"';
mQuote:
Mode:=mNormal;
end;
end;
' ',#9,#10,#13:
begin
if Mode=mNormal then break;
Param+=Params[p];
inc(p);
end;
else
Param+=Params[p];
inc(p);
end;
end;
//writeln('SplitCmdLineParams Param=#'+Param+'#');
ParamList.Add(Param);
end;
end;
initialization
InternalInit;
end.

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

@ -381,7 +381,6 @@ type
Procedure TestCaseOfRange;
Procedure TestCaseOfString;
Procedure TestCaseOfExternalClassConst;
Procedure TestDebugger;
// arrays
Procedure TestArray_Dynamic;
@ -7082,30 +7081,6 @@ begin
]));
end;
procedure TTestModule.TestDebugger;
begin
StartProgram(false);
Add([
'procedure DoIt;',
'begin',
' deBugger;',
' DeBugger();',
'end;',
'begin',
' Debugger;']);
ConvertProgram;
CheckSource('TestDebugger',
LinesToStr([ // statements
'this.DoIt = function () {',
' debugger;',
' debugger;',
'};',
'']),
LinesToStr([ // $mod.$main
'debugger;',
'']));
end;
procedure TTestModule.TestArray_Dynamic;
begin
StartProgram(false);

6
packages/pastojs/tests/tcunitsearch.pas
View File

@ -29,14 +29,14 @@ uses
fpcunit, testregistry,
PScanner, PasTree,
{$IFDEF CheckPasTreeRefCount}PasResolveEval,{$ENDIF}
Pas2jsFileUtils, Pas2jsCompiler, Pas2jsFileCache, Pas2jsLogger,
Pas2jsFileUtils, Pas2jsCompiler, Pas2jsfsCompiler, Pas2jsFileCache, Pas2jsLogger,
tcmodules;
type
{ TTestCompiler }
TTestCompiler = class(TPas2jsCompiler)
TTestCompiler = class(TPas2jsFSCompiler)
private
FExitCode: longint;
protected
@ -229,7 +229,7 @@ begin
{$ENDIF}
FCompiler:=TTestCompiler.Create;
Compiler.Log.OnLog:=@DoLog;
Compiler.FileCache.DirectoryCache.OnReadDirectory:=@OnReadDirectory;
Compiler.FileCache.OnReadDirectory:=@OnReadDirectory;
Compiler.FileCache.OnReadFile:=@OnReadFile;
Compiler.FileCache.OnWriteFile:=@OnWriteFile;
end;

12
packages/pastojs/tests/testpas2js.lpi
View File

@ -19,16 +19,9 @@
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<CommandLineParams Value="--suite=TTestCLI_UnitSearch"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="--suite=TTestCLI_UnitSearch"/>
</local>
</Mode0>
<Mode0 Name="default"/>
</Modes>
</RunParams>
<RequiredPackages Count="2">
@ -110,6 +103,9 @@
</CodeGeneration>
<Other>
<CustomOptions Value="-dVerbosePas2JS"/>
<OtherDefines Count="1">
<Define0 Value="VerbosePas2JS"/>
</OtherDefines>
</Other>
</CompilerOptions>
<Debugging>

2
rtl/inc/generic.inc
View File

@ -76,7 +76,7 @@ begin
then
begin
{ Align on native pointer size }
aligncount:=(PtrUInt(pdest) and (sizeof(PtrUInt)-1));
aligncount:=(sizeof(PtrUInt)-PtrInt(pdest)) and (sizeof(PtrUInt)-1);
dec(count,aligncount);
pend:=psrc+aligncount;
while psrc<pend do

4
rtl/inc/innr.inc
View File

@ -62,8 +62,7 @@ const
fpc_in_leave = 51; {macpas}
fpc_in_cycle = 52; {macpas}
fpc_in_slice = 53;
fpc_in_move_x = 54;
fpc_in_fillchar_x = 55;
fpc_in_unaligned_x = 54;
fpc_in_get_frame = 56;
fpc_in_get_caller_addr = 57;
fpc_in_get_caller_frame = 58;
@ -105,6 +104,7 @@ const
fpc_in_neg_assign_x = 94;
fpc_in_not_assign_x = 95;
fpc_in_faraddr_x = 97;
fpc_in_volatile_x = 98;
{ Internal constant functions }
fpc_in_const_sqr = 100;

32
rtl/linux/arm/abitag.inc Normal file
View File

@ -0,0 +1,32 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2002,2018 by Florian Klaempfl
members of the Free Pascal development team.
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.
**********************************************************************}
procedure ABITag;nostackframe;assembler;
asm
.section ".note.ABI-tag", "a"
.align 4
.long 4
.long 16
.long 1
.asciz "GNU"
.align 4
.long 0
// oldest supported kernel version, just a guess for now (FK)
.long 2,6,0
.align 4
.section ".note.GNU-stack","",@progbits
.text
end;

15
rtl/linux/arm/cprt0.as
View File

@ -131,18 +131,3 @@ __data_start:
.byte 0
.ascii "generated by FPC http://www.freepascal.org\0"
/* We need this stuff to make gdb behave itself, otherwise
gdb will chokes with SIGILL when trying to debug apps.
*/
.section ".note.ABI-tag", "a"
.align 4
.long 1f - 0f
.long 3f - 2f
.long 1
0: .asciz "GNU"
1: .align 4
2: .long 0
.long 2,0,0
3: .align 4
.section .note.GNU-stack,"",%progbits

15
rtl/linux/arm/gprt0.as
View File

@ -143,18 +143,3 @@ __data_start:
.byte 0
.ascii "generated by FPC http://www.freepascal.org\0"
/* We need this stuff to make gdb behave itself, otherwise
gdb will chokes with SIGILL when trying to debug apps.
*/
.section ".note.ABI-tag", "a"
.align 4
.long 1f - 0f
.long 3f - 2f
.long 1
0: .asciz "GNU"
1: .align 4
2: .long 0
.long 2,0,0
3: .align 4
.section .note.GNU-stack,"",%progbits

15
rtl/linux/arm/prt0.as
View File

@ -173,18 +173,3 @@ __data_start:
.byte 0
.ascii "generated by FPC http://www.freepascal.org\0"
/* We need this stuff to make gdb behave itself, otherwise
gdb will chokes with SIGILL when trying to debug apps.
*/
.section ".note.ABI-tag", "a"
.align 4
.long 1f - 0f
.long 3f - 2f
.long 1
0: .asciz "GNU"
1: .align 4
2: .long 0
.long 2,0,0
3: .align 4
.section .note.GNU-stack,"",%progbits

15
rtl/linux/arm/ucprt0.as
View File

@ -168,18 +168,3 @@ __data_start:
.comm operatingsystem_parameter_argc,4
.comm operatingsystem_parameter_argv,4
/* We need this stuff to make gdb behave itself, otherwise
gdb will chokes with SIGILL when trying to debug apps.
*/
.section ".note.ABI-tag", "a"
.align 4
.long 1f - 0f
.long 3f - 2f
.long 1
0: .asciz "GNU"
1: .align 4
2: .long 0
.long 2,0,0
3: .align 4
.section .note.GNU-stack,"",%progbits

32
rtl/linux/i386/abitag.inc Normal file
View File

@ -0,0 +1,32 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2002,2018 by Florian Klaempfl
members of the Free Pascal development team.
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.
**********************************************************************}
procedure ABITag;nostackframe;assembler;
asm
.section ".note.ABI-tag", "a"
.align 4
.long 4
.long 16
.long 1
.asciz "GNU"
.align 4
.long 0
// oldest supported kernel version, just a guess for now (FK)
.long 2,6,0
.align 4
.section ".note.GNU-stack","",@progbits
.text
end;

8
rtl/linux/system.pp
View File

@ -525,6 +525,8 @@ procedure InitTLS; [public,alias:'FPC_INITTLS'];
while assigned(auxp^) do
inc(auxp);
inc(auxp);
phdr:=nil;
phnum:=0;
{ now we are at the auxillary vector }
while assigned(auxp^) do
begin
@ -573,6 +575,12 @@ procedure InitTLS; [public,alias:'FPC_INITTLS'];
{$endif CPUARM}
{$if FPC_FULLVERSION>30200}
{$if defined(CPUI386) or defined(CPUARM)}
{$I abitag.inc}
{$endif defined(CPUI386) or defined(CPUARM)}
{$endif FPC_FULLVERSION>30200}
begin
{$if defined(i386) and not defined(FPC_USE_LIBC)}
InitSyscallIntf;

2
tests/test/tmt1.pp
View File

@ -55,7 +55,7 @@ begin
if BeginThread({$ifdef fpc}@{$endif}f,pointer(i)) <> tthreadid(0) then
inc(started);
while finished<started do
while volatile(finished)<started do
{$ifdef wince}sleep(10){$endif};
writeln(finished);
end.

2
utils/pas2jni/writer.pas
View File

@ -2075,7 +2075,7 @@ begin
end;
// Class ref helpers
if FClasses.IndexOf('system.TClass', nil) >= 0 then begin
if (u.Name = 'system') and (FClasses.IndexOf('system.TClass', nil) >= 0) then begin
Fjs.WriteLn('native static long GetClassRef(int index);');
AddNativeMethod(u, '_GetClassRef', 'GetClassRef', '(I)J');
Fjs.WriteLn('static TClass GetTClass(int index) { TClass c = new TClass(null); c._pasobj=GetClassRef(index); return c; }');

2
utils/pas2js/docs/translation.html
View File

@ -2923,8 +2923,6 @@ End.
Width and precision is supported. str(i:10) will add spaces to the left to fill up to 10 characters.</b>
str(aDouble:1:5) returns a string in decimal format with 5 digits for the fraction.</li>
<li>Intrinsic procedure WriteStr(out s: string; params...)</li>
<li><i>Debugger;</i> converts to <i>debugger;</i>. If a debugger is running
it will break on this line just like a break point.</li>
</ul>
</div>

8
utils/pas2js/nodepas2js.pp
View File

@ -6,7 +6,7 @@ program nodepas2js;
uses
JS, NodeJSApp,
Classes, SysUtils,
Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler;
Pas2jsFileUtils, Pas2jsLogger, pas2jscompiler, Pas2jsfscompiler;
type
@ -14,13 +14,13 @@ type
TPas2jsCLI = class(TNodeJSApplication)
private
FCompiler: TPas2jsCompiler;
FCompiler: TPas2jsFSCompiler;
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
property Compiler: TPas2jsCompiler read FCompiler;
property Compiler: TPas2jsFsCompiler read FCompiler;
end;
procedure TPas2jsCLI.DoRun;
@ -65,7 +65,7 @@ constructor TPas2jsCLI.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
FCompiler:=TPas2jsCompiler.Create;
FCompiler:=TPas2jsFSCompiler.Create;
end;
destructor TPas2jsCLI.Destroy;

10
utils/pas2js/pas2js.pp
View File

@ -12,7 +12,7 @@ uses
cthreads, cwstring,
{$ENDIF}
Classes, SysUtils, CustApp,
Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler;
Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler, pas2jspcucompiler, pas2jscompilerpp, pas2JScompilercfg;
Type
@ -20,14 +20,14 @@ Type
TPas2jsCLI = class(TCustomApplication)
private
FCompiler: TPas2jsCompiler;
FCompiler: TPas2jsPCUCompiler;
FWriteOutputToStdErr: Boolean;
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
property Compiler: TPas2jsCompiler read FCompiler;
property Compiler: TPas2jsPCUCompiler read FCompiler;
property WriteOutputToStdErr: Boolean read FWriteOutputToStdErr write FWriteOutputToStdErr;
end;
@ -66,7 +66,9 @@ constructor TPas2jsCLI.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
FCompiler:=TPas2jsCompiler.Create;
FCompiler:=TPas2jsPCUCompiler.Create;
FCompiler.ConfigSupport:=TPas2JSFileConfigSupport.Create(FCompiler);
FCompiler.PostProcessorSupport:=TPas2JSFSPostProcessorSupport.Create(FCompiler);
end;
destructor TPas2jsCLI.Destroy;