paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 23:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46407 -
This commit is contained in:
nickysn 2020-08-12 22:20:37 +00:00
commit de29036512
48 changed files with 9117 additions and 393 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
.gitattributes vendored
View File

@ -3169,7 +3169,6 @@ packages/fcl-base/examples/contit.pp svneol=native#text/plain
packages/fcl-base/examples/crittest.pp svneol=native#text/plain
packages/fcl-base/examples/csvbom.pp svneol=native#text/plain
packages/fcl-base/examples/databom.txt svneol=native#text/plain
packages/fcl-base/examples/dbugsrv.pp svneol=native#text/plain
packages/fcl-base/examples/debugtest.pp svneol=native#text/plain
packages/fcl-base/examples/decodeascii85.pp svneol=native#text/plain
packages/fcl-base/examples/demoio.pp svneol=native#text/plain
@ -3210,9 +3209,6 @@ packages/fcl-base/examples/parser.dat -text
packages/fcl-base/examples/poolmm1.pp svneol=native#text/plain
packages/fcl-base/examples/poolmm2.pp svneol=native#text/plain
packages/fcl-base/examples/restest.pp svneol=native#text/plain
packages/fcl-base/examples/showver.pp svneol=native#text/plain
packages/fcl-base/examples/showver.rc -text
packages/fcl-base/examples/showver.res -text
packages/fcl-base/examples/simple.xml -text
packages/fcl-base/examples/sitest.pp svneol=native#text/plain
packages/fcl-base/examples/sockcli.pp svneol=native#text/plain
@ -3274,7 +3270,6 @@ packages/fcl-base/src/csvreadwrite.pp svneol=native#text/plain
packages/fcl-base/src/custapp.pp svneol=native#text/plain
packages/fcl-base/src/dummy/eventlog.inc svneol=native#text/plain
packages/fcl-base/src/eventlog.pp svneol=native#text/plain
packages/fcl-base/src/fileinfo.pp svneol=native#text/plain
packages/fcl-base/src/fpexprpars.pp svneol=native#text/plain
packages/fcl-base/src/fpobserver.pp svneol=native#text/plain
packages/fcl-base/src/fptemplate.pp svneol=native#text/plain
@ -3627,8 +3622,12 @@ packages/fcl-extra/examples/double/daemonunit2.lfm svneol=native#text/plain
packages/fcl-extra/examples/double/daemonunit2.pas svneol=native#text/plain
packages/fcl-extra/examples/double/double.pp svneol=native#text/plain
packages/fcl-extra/examples/double/resdaemonapp.pp svneol=native#text/plain
packages/fcl-extra/examples/showver.pp svneol=native#text/pascal
packages/fcl-extra/examples/showver.rc svneol=native#text/plain
packages/fcl-extra/examples/showver.res -text
packages/fcl-extra/fpmake.pp svneol=native#text/pascal
packages/fcl-extra/src/daemonapp.pp svneol=native#text/plain
packages/fcl-extra/src/fileinfo.pp svneol=native#text/pascal
packages/fcl-extra/src/unix/daemonapp.inc svneol=native#text/plain
packages/fcl-extra/src/win/ServiceManager.pas svneol=native#text/plain
packages/fcl-extra/src/win/daemonapp.inc svneol=native#text/plain
@ -3940,6 +3939,7 @@ packages/fcl-process/Makefile.fpc svneol=native#text/plain
packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-process/examples/checkipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/checkipcserver.lpr svneol=native#text/plain
packages/fcl-process/examples/dbugsrv.pp svneol=native#text/plain
packages/fcl-process/examples/demoproject.ico -text
packages/fcl-process/examples/demoproject.lpi svneol=native#text/plain
packages/fcl-process/examples/demoproject.pp svneol=native#text/plain
@ -4156,6 +4156,12 @@ packages/fcl-res/src/machosubreader.inc svneol=native#text/plain
packages/fcl-res/src/machosubwriter.inc svneol=native#text/plain
packages/fcl-res/src/machotypes.pp svneol=native#text/plain
packages/fcl-res/src/machowriter.pp svneol=native#text/plain
packages/fcl-res/src/rclex.inc svneol=native#text/plain
packages/fcl-res/src/rclex.l svneol=native#text/plain
packages/fcl-res/src/rcparser.pas svneol=native#text/pascal
packages/fcl-res/src/rcparser.y svneol=native#text/plain
packages/fcl-res/src/rcparserfn.inc svneol=native#text/plain
packages/fcl-res/src/rcreader.pp svneol=native#text/pascal
packages/fcl-res/src/resdatastream.pp svneol=native#text/plain
packages/fcl-res/src/resfactory.pp svneol=native#text/plain
packages/fcl-res/src/resmerger.pp svneol=native#text/plain
@ -4171,6 +4177,8 @@ packages/fcl-res/src/versionresource.pp svneol=native#text/plain
packages/fcl-res/src/versiontypes.pp svneol=native#text/plain
packages/fcl-res/src/winpeimagereader.pp svneol=native#text/plain
packages/fcl-res/src/xcoffwriter.pp svneol=native#text/plain
packages/fcl-res/src/yyinclude.pp svneol=native#text/pascal
packages/fcl-res/src/yypreproc.pp svneol=native#text/pascal
packages/fcl-res/xml/acceleratorsresource.xml svneol=native#text/plain
packages/fcl-res/xml/bitmapresource.xml svneol=native#text/plain
packages/fcl-res/xml/clean.sh svneol=native#text/plain
@ -9109,6 +9117,11 @@ packages/tosunits/src/aes.pas svneol=native#text/plain
packages/tosunits/src/gemdos.pas svneol=native#text/plain
packages/tosunits/src/vdi.pas svneol=native#text/plain
packages/tosunits/src/xbios.pas svneol=native#text/plain
packages/tplylib/Makefile svneol=native#text/plain
packages/tplylib/Makefile.fpc svneol=native#text/plain
packages/tplylib/fpmake.pp svneol=native#text/pascal
packages/tplylib/src/lexlib.pas svneol=native#text/pascal
packages/tplylib/src/yacclib.pas svneol=native#text/pascal
packages/univint/Makefile svneol=native#text/plain
packages/univint/Makefile.fpc svneol=native#text/plain
packages/univint/Makefile.fpc.fpcmake svneol=native#text/plain
@ -18451,6 +18464,7 @@ tests/webtbs/tw37477.pp svneol=native#text/pascal
tests/webtbs/tw37493.pp svneol=native#text/pascal
tests/webtbs/tw37508.pp svneol=native#text/pascal
tests/webtbs/tw3751.pp svneol=native#text/plain
tests/webtbs/tw37554.pp svneol=native#text/pascal
tests/webtbs/tw3758.pp svneol=native#text/plain
tests/webtbs/tw3764.pp svneol=native#text/plain
tests/webtbs/tw3765.pp svneol=native#text/plain
@ -19532,7 +19546,6 @@ utils/tply/README.txt svneol=native#text/plain
utils/tply/fpmake.pp svneol=native#text/plain
utils/tply/lexbase.pas svneol=native#text/plain
utils/tply/lexdfa.pas svneol=native#text/plain
utils/tply/lexlib.pas svneol=native#text/plain
utils/tply/lexlist.pas svneol=native#text/plain
utils/tply/lexmsgs.pas svneol=native#text/plain
utils/tply/lexopt.pas svneol=native#text/plain
@ -19546,7 +19559,6 @@ utils/tply/tply.doc -text
utils/tply/tply.tex -text
utils/tply/yaccbase.pas svneol=native#text/plain
utils/tply/yaccclos.pas svneol=native#text/plain
utils/tply/yacclib.pas svneol=native#text/plain
utils/tply/yacclook.pas svneol=native#text/plain
utils/tply/yacclr0.pas svneol=native#text/plain
utils/tply/yaccmsgs.pas svneol=native#text/plain

233
compiler/aarch64/cgcpu.pas
View File

@ -580,102 +580,165 @@ implementation
procedure tcgaarch64.a_load_const_reg(list: TAsmList; size: tcgsize; a: tcgint; reg : tregister);
var
preva: tcgint;
opc: tasmop;
shift,maxshift: byte;
shift: byte;
so: tshifterop;
reginited: boolean;
mask: tcgint;
reginited,doinverted: boolean;
manipulated_a: tcgint;
leftover_a: word;
begin
{ if we load a value into a 32 bit register, it is automatically
zero-extended to 64 bit }
if (hi(a)=0) and
(size in [OS_64,OS_S64]) then
begin
size:=OS_32;
reg:=makeregsize(reg,size);
end;
{ values <= 32 bit are stored in a 32 bit register }
if not(size in [OS_64,OS_S64]) then
a:=cardinal(a);
if size in [OS_64,OS_S64] then
begin
mask:=-1;
maxshift:=64;
end
else
begin
mask:=$ffffffff;
maxshift:=32;
end;
{ single movn enough? (to be extended) }
shift:=16;
preva:=a;
repeat
if (a shr shift)=(mask shr shift) then
case a of
{ Small positive number }
$0..$FFFF:
begin
if shift=16 then
list.concat(taicpu.op_reg_const(A_MOVN,reg,not(word(preva))))
list.concat(taicpu.op_reg_const(A_MOVZ, reg, a));
Exit;
end;
{ Small negative number }
-65536..-1:
begin
list.concat(taicpu.op_reg_const(A_MOVN, reg, Word(not a)));
Exit;
end;
{ Can be represented as a negative number more compactly }
$FFFF0000..$FFFFFFFF:
begin
{ if we load a value into a 32 bit register, it is automatically
zero-extended to 64 bit }
list.concat(taicpu.op_reg_const(A_MOVN, makeregsize(reg,OS_32), Word(not a)));
Exit;
end;
else
begin
if size in [OS_64,OS_S64] then
begin
{ Check to see if a is a valid shifter constant that can be encoded in ORR as is }
if is_shifter_const(a,size) then
begin
list.concat(taicpu.op_reg_reg_const(A_ORR,reg,makeregsize(NR_XZR,size),a));
Exit;
end;
{ This determines whether this write can be peformed with an ORR followed by MOVK
by copying the 2nd word to the 4th word for the ORR constant, then overwriting
the 4th word (unless the word is. The alternative would require 3 instructions }
leftover_a := word(a shr 48);
manipulated_a := (a and $0000FFFFFFFFFFFF);
if manipulated_a = $0000FFFFFFFFFFFF then
begin
{ This is even better, as we can just use a single MOVN on the last word }
shifterop_reset(so);
so.shiftmode := SM_LSL;
so.shiftimm := 48;
list.concat(taicpu.op_reg_const_shifterop(A_MOVN, reg, word(not leftover_a), so));
Exit;
end;
manipulated_a := manipulated_a or (((a shr 16) and $FFFF) shl 48);
{ if manipulated_a = a, don't check, because is_shifter_const was already
called for a and it returned False. Reduces processing time. [Kit] }
if (manipulated_a <> a) and is_shifter_const(manipulated_a, size) then
begin
list.concat(taicpu.op_reg_reg_const(A_ORR, reg, makeregsize(NR_XZR, size), manipulated_a));
if (leftover_a <> 0) then
begin
shifterop_reset(so);
so.shiftmode := SM_LSL;
so.shiftimm := 48;
list.concat(taicpu.op_reg_const_shifterop(A_MOVK, reg, leftover_a, so));
end;
Exit;
end;
case a of
{ If a is in the given negative range, it can be stored
more efficiently if it is inverted. }
TCgInt($FFFF000000000000)..-65537:
begin
{ NOTE: This excluded range can be more efficiently
stored as the first 16 bits followed by a shifter constant }
case a of
TCgInt($FFFF0000FFFF0000)..TCgInt($FFFF0000FFFFFFFF):
doinverted := False
else
begin
doinverted := True;
a := not a;
end;
end;
end;
else
doinverted := False;
end;
end
else
begin
a:=cardinal(a);
doinverted:=False;
end;
end;
end;
reginited:=false;
shift:=0;
if doinverted then
opc:=A_MOVN
else
opc:=A_MOVZ;
repeat
{ leftover is shifterconst? (don't check if we can represent it just
as effectively with movz/movk, as this check is expensive) }
if (word(a)<>0) then
begin
if not doinverted and
((shift<tcgsize2size[size]*(8 div 2)) and
((a shr 16)<>0)) and
is_shifter_const(a shl shift,size) then
begin
if reginited then
list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,a shl shift))
else
list.concat(taicpu.op_reg_reg_const(A_ORR,reg,makeregsize(NR_XZR,size),a shl shift));
exit;
end;
{ set all 16 bit parts <> 0 }
if shift=0 then
begin
list.concat(taicpu.op_reg_const(opc,reg,word(a)));
reginited:=true;
end
else
begin
shifterop_reset(so);
so.shiftmode:=SM_LSL;
so.shiftimm:=shift-16;
list.concat(taicpu.op_reg_const_shifterop(A_MOVN,reg,not(word(preva)),so));
so.shiftimm:=shift;
if not reginited then
begin
list.concat(taicpu.op_reg_const_shifterop(opc,reg,word(a),so));
reginited:=true;
end
else
begin
if doinverted then
list.concat(taicpu.op_reg_const_shifterop(A_MOVK,reg,word(not a),so))
else
list.concat(taicpu.op_reg_const_shifterop(A_MOVK,reg,word(a),so));
end;
end;
exit;
end;
{ only try the next 16 bits if the current one is all 1 bits, since
the movn will set all lower bits to 1 }
if word(a shr (shift-16))<>$ffff then
break;
a:=a shr 16;
inc(shift,16);
until shift=maxshift;
reginited:=false;
shift:=0;
{ can be optimized later to use more movn }
repeat
{ leftover is shifterconst? (don't check if we can represent it just
as effectively with movz/movk, as this check is expensive) }
if ((shift<tcgsize2size[size]*(8 div 2)) and
(word(a)<>0) and
((a shr 16)<>0)) and
is_shifter_const(a shl shift,size) then
begin
if reginited then
list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,a shl shift))
else
list.concat(taicpu.op_reg_reg_const(A_ORR,reg,makeregsize(NR_XZR,size),a shl shift));
exit;
end;
{ set all 16 bit parts <> 0 }
if (word(a)<>0) or
((shift=0) and
(a=0)) then
if shift=0 then
begin
list.concat(taicpu.op_reg_const(A_MOVZ,reg,word(a)));
reginited:=true;
end
else
begin
shifterop_reset(so);
so.shiftmode:=SM_LSL;
so.shiftimm:=shift;
if not reginited then
begin
opc:=A_MOVZ;
reginited:=true;
end
else
opc:=A_MOVK;
list.concat(taicpu.op_reg_const_shifterop(opc,reg,word(a),so));
end;
preva:=a;
a:=a shr 16;
inc(shift,16);
until word(preva)=preva;
until a = 0;
if not reginited then
internalerror(2014102702);
end;

31
compiler/comprsrc.pas
View File

@ -78,13 +78,14 @@ procedure CollectResourceFiles;
Var
ResCompiler : String;
RCCompiler : String;
RCForceFPCRes : Boolean;
implementation
uses
SysUtils,
cutils,cfileutl,cclasses,
Globtype,Globals,Verbose,Fmodule, comphook,cpuinfo;
Globtype,Globals,Verbose,Fmodule, comphook,cpuinfo,rescmn;
{****************************************************************************
TRESOURCEFILE
@ -126,7 +127,10 @@ var
begin
if output=roRES then
begin
s:=target_res.rccmd;
if RCForceFPCRes then
s:=FPCResRCArgs
else
s:=target_res.rccmd;
Replace(s,'$RES',maybequoted(OutName));
Replace(s,'$RC',maybequoted(fname));
ObjUsed:=False;
@ -162,7 +166,10 @@ var
begin
Result:=true;
if output=roRES then
Bin:=SelectBin(RCCompiler,target_res.rcbin)
if RCForceFPCRes then
Bin:=SelectBin(RCCompiler,FPCResUtil)
else
Bin:=SelectBin(RCCompiler,target_res.rcbin)
else
Bin:=SelectBin(ResCompiler,target_res.resbin);
if bin='' then
@ -265,8 +272,11 @@ begin
srcfilepath:=ExtractFilePath(current_module.mainsource);
if output=roRES then
begin
s:=target_res.rccmd;
if target_res.rcbin = 'windres' then
if RCForceFPCRes then
s:=FPCResRCArgs
else
s:=target_res.rccmd;
if (target_res.rcbin = 'windres') and not RCForceFPCRes then
Replace(s,'$RC',WindresFileName(fname))
else
Replace(s,'$RC',maybequoted(fname));
@ -317,7 +327,7 @@ begin
if respath='' then
respath:='.';
Replace(s,'$INC',maybequoted(respath));
if (output=roRes) and (target_res.rcbin='windres') then
if (output=roRes) and (target_res.rcbin='windres') and not RCForceFPCRes then
begin
{ try to find a preprocessor }
preprocessorbin := respath+'cpp'+source_info.exeext;
@ -555,4 +565,13 @@ begin
resourcefile.free;
end;
procedure initglobals;
begin
ResCompiler:='';
RCCompiler:='';
RCForceFPCRes:=false;
end;
initialization
register_initdone_proc(@initglobals,nil);
end.

3
compiler/msg/errore.msg
View File

@ -3960,8 +3960,9 @@ A*2CV<x>_Set section threadvar model to <x>
**2Fd_Disable the compiler's internal directory cache
**2FD<x>_Set the directory where to search for compiler utilities
**2Fe<x>_Redirect error output to <x>
**2Ff<x>_Add <x> to framework path (Darwin only)
**2FE<x>_Set exe/unit output path to <x>
**2Ff<x>_Add <x> to framework path (Darwin only)
**2FF_Use fpcres as RC to RES compiler instead of windres or gorc
**2Fi<x>_Add <x> to include path
**2Fl<x>_Add <x> to library path
**2FL<x>_Use <x> as dynamic linker

2
compiler/msgidx.inc
View File

@ -1126,7 +1126,7 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 85624;
MsgTxtSize = 85690;
MsgIdxMax : array[1..20] of longint=(
28,106,356,129,99,63,143,36,223,68,

305
compiler/msgtxt.inc
View File

@ -1,8 +1,8 @@
const msgtxt_codepage=20127;
{$ifdef Delphi}
const msgtxt : array[0..000356] of string[240]=(
const msgtxt : array[0..000357] of string[240]=(
{$else Delphi}
const msgtxt : array[0..000356,1..240] of char=(
const msgtxt : array[0..000357,1..240] of char=(
{$endif Delphi}
'01000_T_Compiler: $1'#000+
'01001_D_Compiler OS: $1'#000+
@ -1591,186 +1591,187 @@ const msgtxt : array[0..000356,1..240] of char=(
'**2Fd_Disable the compiler'#039's internal directory cache'#010+
'**2FD<x>_Set the directory where to search for compiler utilities'#010+
'**2Fe<x>_Redirect error output to <x>'#010+
'**2Ff<x>_Add <x> to framework path (Darwin only)'#010+
'**2FE','<x>_Set exe/unit output path to <x>'#010+
'**2FE<x>_Set exe/unit output path to <x>'#010+
'**2Ff<x>_Add ','<x> to framework path (Darwin only)'#010+
'**2FF_Use fpcres as RC to RES compiler instead of windres or gorc'#010+
'**2Fi<x>_Add <x> to include path'#010+
'**2Fl<x>_Add <x> to library path'#010+
'**2FL<x>_Use <x> as dynamic linker'#010+
'**2Fm<x>_Load unicode conversion table from <x>.txt in the compiler di'+
'r'#010+
'**2FM<x>_Set the directory wher','e to search for unicode binary files'#010+
'**2Fm<x>_Load unicode conversion tabl','e from <x>.txt in the compiler '+
'dir'#010+
'**2FM<x>_Set the directory where to search for unicode binary files'#010+
'**2FN<x>_Add <x> to list of default unit scopes (namespaces)'#010+
'**2Fo<x>_Add <x> to object path'#010+
'**2Fr<x>_Load error message file <x>'#010+
'**2FR<x>_Set resource (.res) linker to <x>'#010+
'**2Fu<x>_Add <x> to unit path'#010,
'**2FR<x','>_Set resource (.res) linker to <x>'#010+
'**2Fu<x>_Add <x> to unit path'#010+
'**2FU<x>_Set unit output path to <x>, overrides -FE'#010+
'**2FW<x>_Store generated whole-program optimization feedback in <x>'#010+
'**2Fw<x>_Load previously stored whole-program optimization feedback fr'+
'om <x>'#010+
'*g1g_Generate debug information (default fo','rmat for target)'#010+
'**2Fw<x>_Load previously stored whole-program optimiza','tion feedback '+
'from <x>'#010+
'*g1g_Generate debug information (default format for target)'#010+
'*g2gc_Generate checks for pointers (experimental, only available on so'+
'me targets, might generate false positive)'#010+
'*g2gh_Use heaptrace unit (for memory leak/corruption debugging)'#010+
'*g2gl_Use line info unit (show more info with ','backtraces)'#010+
'*g2gh_Use heaptrace unit (for memory leak/co','rruption debugging)'#010+
'*g2gl_Use line info unit (show more info with backtraces)'#010+
'*g2gm_Generate Microsoft CodeView debug information (experimental)'#010+
'*g2go<x>_Set debug information options'#010+
'*g3godwarfsets_ Enable DWARF '#039'set'#039' type debug information (bre'+
'aks gdb < 6.5)'#010+
'*g3gostabsabsincludes_ Store absolute/full in','clude file paths in Sta'+
'bs'#010+
'*g3godwarfsets_ Enable DWARF '#039'set'#039' type debug informatio','n (b'+
'reaks gdb < 6.5)'#010+
'*g3gostabsabsincludes_ Store absolute/full include file paths in Stabs'+
#010+
'*g3godwarfmethodclassprefix_ Prefix method names in DWARF with class n'+
'ame'#010+
'*g3godwarfcpp_ Simulate C++ debug information in DWARF'#010+
'*g3godwarfomflinnum_ Generate line number information in OMF LINNUM re'+
'cords in MS LIN','K format in addition to the DWARF debug information ('+
'*g3godwarfomflinnum','_ Generate line number information in OMF LINNUM '+
'records in MS LINK format in addition to the DWARF debug information ('+
'Open Watcom Debugger/Linker compatibility)'#010+
'*g2gp_Preserve case in stabs symbol names'#010+
'*g2gs_Generate Stabs debug information'#010+
'*g2gt_Trash local variables (to detect uninitialized uses; mult','iple '+
#039't'#039' changes the trashing value)'#010+
'*g2gs_Generate Stabs debug informati','on'#010+
'*g2gt_Trash local variables (to detect uninitialized uses; multiple '#039+
't'#039' changes the trashing value)'#010+
'*g2gv_Generates programs traceable with Valgrind'#010+
'*g2gw_Generate DWARFv2 debug information (same as -gw2)'#010+
'*g2gw2_Generate DWARFv2 debug information'#010+
'*g2gw2_Generate DWARFv2 debug in','formation'#010+
'*g2gw3_Generate DWARFv3 debug information'#010+
'*g2gw4_Generat','e DWARFv4 debug information (experimental)'#010+
'*g2gw4_Generate DWARFv4 debug information (experimental)'#010+
'**1i_Information'#010+
'**2iD_Return compiler date'#010+
'**2iSO_Return compiler OS'#010+
'**2iSP_Return compiler host processor'#010+
'**2iTO_Return target OS'#010+
'**2iTO_Return target OS',#010+
'**2iTP_Return target processor'#010+
'**2iV_Return short compiler versio','n'#010+
'**2iV_Return short compiler version'#010+
'**2iW_Return full compiler version'#010+
'**2ia_Return list of supported ABI targets'#010+
'**2ib_Return the used code generation backend type'#010+
'**2ic_Return list of supported CPU instruction sets'#010+
'**2ic_Return list of supported CPU instruct','ion sets'#010+
'**2if_Return list of supported FPU instruction sets'#010+
'**2ii','_Return list of supported inline assembler modes'#010+
'**2ii_Return list of supported inline assembler modes'#010+
'**2im_Return list of supported modeswitches'#010+
'**2io_Return list of supported optimizations'#010+
'**2ir_Return list of recognized compiler and RTL features'#010+
'**2ir_Return list of recognized comp','iler and RTL features'#010+
'**2it_Return list of supported targets'#010+
'**2iu','_Return list of supported microcontroller types'#010+
'**2iu_Return list of supported microcontroller types'#010+
'**2iw_Return list of supported whole program optimizations'#010+
'**1I<x>_Add <x> to include path'#010+
'**1k<x>_Pass <x> to the linker'#010+
'**1l_Write logo'#010+
'**1M<x>_Set language mode to <x> / enable modeswitch <','x> (see option'+
' -im)'#010+
'**1l','_Write logo'#010+
'**1M<x>_Set language mode to <x> / enable modeswitch <x> (see option -'+
'im)'#010+
'**2Mfpc_Free Pascal dialect (default)'#010+
'**2Mobjfpc_FPC mode with Object Pascal support'#010+
'**2Mdelphi_Delphi 7 compatibility mode'#010+
'**2Mtp_TP/BP 7.0 compatibility mode'#010+
'**2Mtp_TP/BP 7.0 compatibility',' mode'#010+
'**2Mmacpas_Macintosh Pascal dialects compatibility mode'#010+
'**2M','iso_ISO 7185 mode'#010+
'**2Miso_ISO 7185 mode'#010+
'**2Mextendedpascal_ISO 10206 mode'#010+
'**2Mdelphiunicode_Delphi 2009 and later compatibility mode'#010+
'**2*_Each mode (as listed above) enables its default set of modeswitch'+
'es.'#010+
'**2*_Other modeswitches are disabled and need to be ena','bled one by a'+
'nother.'#010+
'**2*_Each mode (as listed above) enables its default set of mod','eswit'+
'ches.'#010+
'**2*_Other modeswitches are disabled and need to be enabled one by ano'+
'ther.'#010+
'**1M<x>-_Disable modeswitch <x> (see option -im)'#010+
'**1n_Do not read the default config files'#010+
'**1o<x>_Change the name of the executable produced to <x>'#010+
'**1O<x>_Optimizations:'#010+
'**1O','<x>_Optimizations:'#010+
'**2O-_Disable optimizations'#010+
'**2O1_Level 1 optim','izations (quick and debugger friendly)'#010+
'**2O1_Level 1 optimizations (quick and debugger friendly)'#010+
'**2O2_Level 2 optimizations (-O1 + quick optimizations)'#010+
'**2O3_Level 3 optimizations (-O2 + slow optimizations)'#010+
'**2O4_Level 4 optimizations (-O3 + optimizations which might have unex'+
'pected side effects)',#010+
'**2O4_Level 4 optimizati','ons (-O3 + optimizations which might have un'+
'expected side effects)'#010+
'**2Oa<x>=<y>_Set alignment'#010+
'**2Oo[NO]<x>_Enable or disable optimizations; see fpc -i or fpc -io fo'+
'r possible values'#010+
'**2Op<x>_Set target cpu for optimizing; see fpc -i or fpc -ic for poss'+
'ible values'#010+
'**2OW<x>_Generate whole-program optimizati','on feedback for optimizati'+
'on <x>; see fpc -i or fpc -iw for possible values'#010+
'**2Op<x>_Set target cpu for optimizing; see fpc -i or fpc ','-ic for po'+
'ssible values'#010+
'**2OW<x>_Generate whole-program optimization feedback for optimization'+
' <x>; see fpc -i or fpc -iw for possible values'#010+
'**2Ow<x>_Perform whole-program optimization <x>; see fpc -i or fpc -iw'+
' for possible values'#010+
'**2Os_Optimize for size rather than speed'#010+
'**1pg_Generate profile code for',' gprof (defines FPC_PROFILE)'#010+
'**2Os_O','ptimize for size rather than speed'#010+
'**1pg_Generate profile code for gprof (defines FPC_PROFILE)'#010+
'F*1P<x>_Target CPU / compiler related options:'#010+
'F*2PB_Show default compiler binary'#010+
'F*2PP_Show default target cpu'#010+
'F*2P<x>_Set target CPU (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipse'+
'l,powerpc,powerpc64,sparc,x86','_64)'#010+
'F*2P<x>_Set target CPU (aarch64,a','rm,avr,i386,i8086,jvm,m68k,mips,mip'+
'sel,powerpc,powerpc64,sparc,x86_64)'#010+
'**1R<x>_Assembler reading style:'#010+
'**2Rdefault_Use default assembler for target'#010+
'3*2Ratt_Read AT&T style assembler'#010+
'3*2Rintel_Read Intel style assembler'#010+
'4*2Ratt_Read AT&T style assembler'#010+
'4*2Ratt_Read AT&T st','yle assembler'#010+
'4*2Rintel_Read Intel style assembler'#010+
'8*2Ratt_Read AT','&T style assembler'#010+
'8*2Ratt_Read AT&T style assembler'#010+
'8*2Rintel_Read Intel style assembler'#010+
'6*2RMOT_Read Motorola style assembler'#010+
'**1S<x>_Syntax options:'#010+
'**2S2_Same as -Mobjfpc'#010+
'**2Sc_Support operators like C (*=,+=,/= and -=)'#010+
'**2Sc_Support operators like C (*','=,+=,/= and -=)'#010+
'**2Sa_Turn on assertions'#010+
'**2Sd_Same as -Mdelphi'#010+
'**','2Se<x>_Error options. <x> is a combination of the following:'#010+
'**2Se<x>_Error options. <x> is a combination of the following:'#010+
'**3*_<n> : Compiler halts after the <n> errors (default is 1)'#010+
'**3*_w : Compiler also halts after warnings'#010+
'**3*_n : Compiler also halts after notes'#010+
'**3*_h : Compiler also halts aft','er hints'#010+
'**3*_n ',': Compiler also halts after notes'#010+
'**3*_h : Compiler also halts after hints'#010+
'**2Sf_Enable certain features in compiler and RTL; see fpc -i or fpc -'+
'ir for possible values)'#010+
'**2Sg_Enable LABEL and GOTO (default in -Mtp and -Mdelphi)'#010+
'**2Sh_Use reference counted strings (ansistring by default) instead of'+
' shortst','rings'#010+
'**2Sh_Use re','ference counted strings (ansistring by default) instead '+
'of shortstrings'#010+
'**2Si_Turn on inlining of procedures/functions declared as "inline"'#010+
'**2Sj_Allows typed constants to be writeable (default in all modes)'#010+
'**2Sk_Load fpcylix unit'#010+
'**2SI<x>_Set interface style to <x>'#010+
'**3SIcom_COM compatible interface (def','ault)'#010+
'**2SI<x>','_Set interface style to <x>'#010+
'**3SIcom_COM compatible interface (default)'#010+
'**3SIcorba_CORBA compatible interface'#010+
'**2Sm_Support macros like C (global)'#010+
'**2So_Same as -Mtp'#010+
'**2Sr_Transparent file names in ISO mode'#010+
'**2Ss_Constructor name must be init (destructor must be done)'#010+
'**2Sv_Support vector processing (use ','CPU vector extensions if availa'+
'ble)'#010+
'**2Ss_Constructor name must be in','it (destructor must be done)'#010+
'**2Sv_Support vector processing (use CPU vector extensions if availabl'+
'e)'#010+
'**2Sx_Enable exception keywords (default in Delphi/ObjFPC modes)'#010+
'**2Sy_@<pointer> returns a typed pointer, same as $T+'#010+
'**1s_Do not call assembler and linker'#010+
'**1s_Do not call as','sembler and linker'#010+
'**2sh_Generate script to link on host'#010+
'**2st_Gen','erate script to link on target'#010+
'**2st_Generate script to link on target'#010+
'**2sr_Skip register allocation phase (use with -alr)'#010+
'**1T<x>_Target operating system:'#010+
'3*2Tandroid_Android'#010+
'3*2Taros_AROS'#010+
'3*2Tbeos_BeOS'#010+
'3*2Tdarwin_Darwin/Mac OS X'#010+
'3*2Tdarwi','n_Darwin/Mac OS X'#010+
'3*2Tembedded_Embedded'#010+
'3*2Temx_OS/2 via EMX (incl','uding EMX/RSX extender)'#010+
'3*2Temx_OS/2 via EMX (including EMX/RSX extender)'#010+
'3*2Tfreebsd_FreeBSD'#010+
'3*2Tgo32v2_Version 2 of DJ Delorie DOS extender'#010+
'3*2Thaiku_Haiku'#010+
'3*2Tiphonesim_iPhoneSimulator from iOS SDK 3.2+ (older versions: -Tdar'+
'win)'#010+
'3*2Tiphonesim_iPhoneSimulator from iOS SDK 3.2+ (older versions: -','Td'+
'arwin)'#010+
'3*2Tlinux_Linux'#010+
'3*2Tnativent_Native NT API (experimental)',#010+
'3*2Tnativent_Native NT API (experimental)'#010+
'3*2Tnetbsd_NetBSD'#010+
'3*2Tnetware_Novell Netware Module (clib)'#010+
'3*2Tnetwlibc_Novell Netware Module (libc)'#010+
'3*2Topenbsd_OpenBSD'#010+
'3*2Tos2_OS/2 / eComStation'#010+
'3*2Tsymbian_Symbian OS'#010+
'3*2Tsolaris_Solaris'#010+
'3*','2Tsolaris_Solaris'#010+
'3*2Twatcom_Watcom compatible DOS extender'#010+
'3*2Twd','osx_WDOSX DOS extender'#010+
'3*2Twdosx_WDOSX DOS extender'#010+
'3*2Twin32_Windows 32 Bit'#010+
'3*2Twince_Windows CE'#010+
'4*2Tandroid_Android'#010+
'4*2Taros_AROS'#010+
'4*2Tdarwin_Darwin/Mac OS X'#010+
'4*2Tdragonfly_DragonFly BSD'#010+
'4*2Tembedded_Embedded'#010+
'4*2Tembedded_Emb','edded'#010+
'4*2Tfreebsd_FreeBSD'#010+
'4*2Thaiku_Haiku'#010+
'4*2Tiphonesim_iPhoneSimu','lator'#010+
'4*2Tiphonesim_iPhoneSimulator'#010+
'4*2Tlinux_Linux'#010+
'4*2Tnetbsd_NetBSD'#010+
'4*2Topenbsd_OpenBSD'#010+
@ -1778,20 +1779,20 @@ const msgtxt : array[0..000356,1..240] of char=(
'4*2Twin64_Win64 (64 bit Windows systems)'#010+
'6*2Tamiga_Commodore Amiga'#010+
'6*2Tatari_Atari ST/STe/TT'#010+
'6*2Tembedded_Embedded'#010+
'6','*2Tembedded_Embedded'#010+
'6*2Tlinux_Linux'#010+
'6*2Tnetbsd_NetBSD'#010+
'6*2Tmacoscl','assic_Classic Mac OS'#010+
'6*2Tmacosclassic_Classic Mac OS'#010+
'6*2Tpalmos_PalmOS'#010+
'8*2Tembedded_Embedded'#010+
'8*2Tmsdos_MS-DOS (and compatible)'#010+
'8*2Twin16_Windows 16 Bit'#010+
'A*2Tandroid_Android'#010+
'A*2Taros_AROS'#010+
'A*2Tdarwin_Darwin/iPhoneOS/iOS'#010+
'A*2Tdarwin_Darwin/iP','honeOS/iOS'#010+
'A*2Tembedded_Embedded'#010+
'A*2Tfreertos_FreeRTOS'#010+
'A*2Tgba_Gam','e Boy Advance'#010+
'A*2Tgba_Game Boy Advance'#010+
'A*2Tlinux_Linux'#010+
'A*2Tnds_Nintendo DS'#010+
'A*2Tnetbsd_NetBSD'#010+
@ -1800,10 +1801,10 @@ const msgtxt : array[0..000356,1..240] of char=(
'A*2Twince_Windows CE'#010+
'a*2Tandroid_Android'#010+
'a*2Tdarwin_Darwin/iOS'#010+
'a*2Tlinux_Linux'#010+
'a*2Tl','inux_Linux'#010+
'a*2Twin64_Windows 64'#010+
'J*2Tandroid_Android'#010+
'J*2Tjava_Java'#010,
'J*2Tjava_Java'#010+
'm*2Tandroid_Android'#010+
'm*2Tembedded_Embedded'#010+
'm*2Tlinux_Linux'#010+
@ -1812,10 +1813,10 @@ const msgtxt : array[0..000356,1..240] of char=(
'P*2Taix_AIX'#010+
'P*2Tamiga_AmigaOS'#010+
'P*2Tdarwin_Darwin/Mac OS X'#010+
'P*2Tembedded_Embedded'#010+
'P*2Tembedded_Embedded',#010+
'P*2Tlinux_Linux'#010+
'P*2Tmacosclassic_Classic Mac OS'#010+
'P*2Tmorphos_Morph','OS'#010+
'P*2Tmorphos_MorphOS'#010+
'P*2Tnetbsd_NetBSD'#010+
'P*2Twii_Wii'#010+
'p*2Taix_AIX'#010+
@ -1825,164 +1826,162 @@ const msgtxt : array[0..000356,1..240] of char=(
'R*2Tlinux_Linux'#010+
'R*2Tembedded_Embedded'#010+
'r*2Tlinux_Linux'#010+
'r*2Tembedded_Embedded'#010+
'r*2Tembedd','ed_Embedded'#010+
'S*2Tlinux_Linux'#010+
'S*2Tsolaris_Solaris'#010+
's*2Tlinux_Linux'#010+
'V*','2Tembedded_Embedded'#010+
'V*2Tembedded_Embedded'#010+
'x*2Tembedded_Embedded'#010+
'x*2Tfreertos_FreeRTOS'#010+
'x*2Tlinux_Linux'#010+
'Z*2Tembedded_Embedded'#010+
'Z*2Tzxspectrum_ZX Spectrum'#010+
'Z*2Tmsxdos_MSX-DOS'#010+
'**1u<x>_Undefines the symbol <x>'#010+
'**1u<x>_Undefines the symb','ol <x>'#010+
'**1U_Unit options:'#010+
'**2Un_Do not check where the unit name m','atches the file name'#010+
'**2Un_Do not check where the unit name matches the file name'#010+
'**2Ur_Generate release unit files (never automatically recompiled)'#010+
'**2Us_Compile a system unit'#010+
'**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+
'**2*_e : Show errors (default) 0 : Show nothing (ex','cept errors'+
')'#010+
'**1v<x>_Be verbose. <x> is a combination of the following ','letters:'#010+
'**2*_e : Show errors (default) 0 : Show nothing (except errors)'#010+
'**2*_w : Show warnings u : Show unit info'#010+
'**2*_n : Show notes t : Show tried/used files'#010+
'**2*_h : Show hints c : Show conditionals'#010+
'**2*_i : Show general info d : Show deb','ug info'#010+
'**2*_h : Show hints c : S','how conditionals'#010+
'**2*_i : Show general info d : Show debug info'#010+
'**2*_l : Show linenumbers r : Rhide/GCC compatibility mode'#010+
'**2*_s : Show time stamps q : Show message numbers'#010+
'**2*_a : Show everything x : Show info about invoked tools'+
#010+
'**2*_b : Write file names mes','sages p : Write tree.log with parse t'+
'ree'#010+
'**2*_a : Show everything ',' x : Show info about invoked too'+
'ls'#010+
'**2*_b : Write file names messages p : Write tree.log with parse tre'+
'e'#010+
'**2*_ with full path v : Write fpcdebug.txt with'#010+
'**2*_z : Write output to stderr lots of debugging info'#010+
'**2*_m<x>,<y> : Do not show messages numbered <x> and <y>'#010+
'F*1V<x>_Ap','pend '#039'-<x>'#039' to the used compiler binary name (e.g.'+
' for version)'#010+
'**','2*_m<x>,<y> : Do not show messages numbered <x> and <y>'#010+
'F*1V<x>_Append '#039'-<x>'#039' to the used compiler binary name (e.g. f'+
'or version)'#010+
'**1W<x>_Target-specific options (targets)'#010+
'3*2WA_Specify native type application (Windows)'#010+
'4*2WA_Specify native type application (Windows)'#010+
'A*2WA_Specify native type application ','(Windows)'#010+
'4*2WA_Specify native',' type application (Windows)'#010+
'A*2WA_Specify native type application (Windows)'#010+
'3*2Wb_Create a bundle instead of a library (Darwin)'#010+
'P*2Wb_Create a bundle instead of a library (Darwin)'#010+
'p*2Wb_Create a bundle instead of a library (Darwin)'#010+
'a*2Wb_Create a bundle instead of a library (Darwin)'#010+
'A*2Wb_Create a bundle ','instead of a library (Darwin)'#010+
'a*2Wb_Cr','eate a bundle instead of a library (Darwin)'#010+
'A*2Wb_Create a bundle instead of a library (Darwin)'#010+
'4*2Wb_Create a bundle instead of a library (Darwin)'#010+
'3*2WB_Create a relocatable image (Windows, Symbian)'#010+
'3*2WB<x>_Set image base to <x> (Windows, Symbian)'#010+
'3*2WB<x>_Set image base to <x> (Windows,',' Symbian)'#010+
'4*2WB_Create a relocatable image (Windows)'#010+
'4*2WB<x>_Set ','image base to <x> (Windows)'#010+
'4*2WB<x>_Set image base to <x> (Windows)'#010+
'A*2WB_Create a relocatable image (Windows, Symbian)'#010+
'A*2WB<x>_Set image base to <x> (Windows, Symbian)'#010+
'Z*2WB<x>_Set image base to <x> (ZX Spectrum)'#010+
'Z*2WB<x>_Set image base to <x> (ZX Spectrum)',#010+
'3*2WC_Specify console type application (EMX, OS/2, Windows)'#010+
'4*2WC','_Specify console type application (Windows)'#010+
'4*2WC_Specify console type application (Windows)'#010+
'A*2WC_Specify console type application (Windows)'#010+
'P*2WC_Specify console type application (Classic Mac OS)'#010+
'3*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
'4*2WD_Use DEFFILE to export f','unctions of DLL or EXE (Windows)'#010+
'3*2WD_Use DEFFILE to expo','rt functions of DLL or EXE (Windows)'#010+
'4*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
'A*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
'3*2We_Use external resources (Darwin)'#010+
'4*2We_Use external resources (Darwin)'#010+
'a*2We_Use external resources (Darwin)'#010+
'A*2We_Use external resources (D','arwin)'#010+
'a*2','We_Use external resources (Darwin)'#010+
'A*2We_Use external resources (Darwin)'#010+
'P*2We_Use external resources (Darwin)'#010+
'p*2We_Use external resources (Darwin)'#010+
'3*2WF_Specify full-screen type application (EMX, OS/2)'#010+
'3*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+
'4*2WG_Specify graphic type application (Wi','ndows)'#010+
'3*2WG_Specify graphic type applicati','on (EMX, OS/2, Windows)'#010+
'4*2WG_Specify graphic type application (Windows)'#010+
'A*2WG_Specify graphic type application (Windows)'#010+
'P*2WG_Specify graphic type application (Classic Mac OS)'#010+
'3*2Wi_Use internal resources (Darwin)'#010+
'4*2Wi_Use internal resources (Darwin)'#010+
'4*2Wi_Use internal resou','rces (Darwin)'#010+
'a*2Wi_Use internal resources (Darwin)'#010+
'A*2Wi_Use inte','rnal resources (Darwin)'#010+
'A*2Wi_Use internal resources (Darwin)'#010+
'P*2Wi_Use internal resources (Darwin)'#010+
'p*2Wi_Use internal resources (Darwin)'#010+
'3*2WI_Turn on/off the usage of import sections (Windows)'#010+
'4*2WI_Turn on/off the usage of import sections (Windows)'#010+
'A*2WI_Turn on/off the usag','e of import sections (Windows)'#010+
'4*2WI_Turn on/off',' the usage of import sections (Windows)'#010+
'A*2WI_Turn on/off the usage of import sections (Windows)'#010+
'8*2Wh_Use huge code for units (ignored for models with CODE in a uniqu'+
'e segment)'#010+
'8*2Wm<x>_Set memory model'#010+
'8*3WmTiny_Tiny memory model'#010+
'8*3WmSmall_Small memory model (default)'#010+
'8*3WmSma','ll_Small memory model (default)'#010+
'8*3WmMedium_Medium memory model'#010+
'8*','3WmCompact_Compact memory model'#010+
'8*3WmCompact_Compact memory model'#010+
'8*3WmLarge_Large memory model'#010+
'8*3WmHuge_Huge memory model'#010+
'3*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
'n)'#010+
'4*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
'n)'#010+
'p*2W','M<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Dar'+
'4*2WM<x>_Mi','nimum Mac OS X deployment version: 10.4, 10.5.1, ... (Dar'+
'win)'#010+
'p*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
'n)'#010+
'P*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
'n)'#010+
'3*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
'4*2WN_Do not generate reloca','tion code, needed for debugging (Windows'+
'3*2WN_Do not generate relocation',' code, needed for debugging (Windows'+
')'#010+
'4*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
'A*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
'A*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu for possib'+
'le values'#010+
'm*2Wp<x>_Specify the controller type; see fpc -i',' or fpc -iu for poss'+
'A*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu fo','r poss'+
'ible values'#010+
'm*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu for possib'+
'le values'#010+
'R*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu for possib'+
'le values'#010+
'V*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu for possib'+
'le values'#010+
'x*2Wp<x>_Specify the controller type; see fpc -i',' or fpc -iu for poss'+
'V*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu fo','r poss'+
'ible values'#010+
'x*2Wp<x>_Specify the controller type; see fpc -i or fpc -iu for possib'+
'le values'#010+
'3*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (iphonesim)'#010+
'4*2WP<x>_Minimum iOS deployment version: 8.0, 8.0.2, ... (iphonesim)'#010+
'a*2WP<x>_Minimum iOS deployment version: 7.0, 7.1.2, ... (Darwin)'#010+
'A*2W','P<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (Darwin)'#010+
'a*2W','P<x>_Minimum iOS deployment version: 7.0, 7.1.2, ... (Darwin)'#010+
'A*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (Darwin)'#010+
'3*2WR_Generate relocation code (Windows)'#010+
'4*2WR_Generate relocation code (Windows)'#010+
'A*2WR_Generate relocation code (Windows)'#010+
'A*2WR_Generate relocation code',' (Windows)'#010+
'8*2Wt<x>_Set the target executable format'#010+
'8*3Wtexe_Crea','te a DOS .EXE file (default)'#010+
'8*3Wtexe_Create a DOS .EXE file (default)'#010+
'8*3Wtcom_Create a DOS .COM file (requires tiny memory model)'#010+
'P*2WT_Specify MPW tool type application (Classic Mac OS)'#010+
'**2WX_Enable executable stack (Linux)'#010+
'**2WX_Enable executable sta','ck (Linux)'#010+
'**1X_Executable options:'#010+
'**2X9_Generate linkerscript fo','r GNU Binutils ld older than version 2'+
'.19.1 (Linux)'#010+
'**2X9_Generate linkerscript for GNU Binutils ld older than version 2.1'+
'9.1 (Linux)'#010+
'**2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Lin'+
'ux)'#010+
'**2Xd_Do not search default library path (sometimes required for cross'+
'-compiling when not using -XR)'#010+
'**2Xe_Use ext','ernal linker'#010+
'**2Xd_Do not search default library path (someti','mes required for cro'+
'ss-compiling when not using -XR)'#010+
'**2Xe_Use external linker'#010+
'**2Xf_Substitute pthread library name for linking (BSD)'#010+
'**2Xg_Create debuginfo in a separate file and add a debuglink section '+
'to executable'#010+
'**2XD_Try to link units dynamically (defines FPC_LINK_DYNAMIC)'#010+
'**2Xi_Use internal ','linker'#010+
'**2XD_Try to link uni','ts dynamically (defines FPC_LINK_DYNAMIC)'#010+
'**2Xi_Use internal linker'#010+
'L*2XlS<x>_LLVM utilties suffix (e.g. -7 in case clang is called clang-'+
'7)'#010+
'**2XLA_Define library substitutions for linking'#010+
'**2XLO_Define order of library linking'#010+
'**2XLD_Exclude default order of standard libraries'#010+
'**2Xm_Generate link ma','p'#010+
'**2XLD_','Exclude default order of standard libraries'#010+
'**2Xm_Generate link map'#010+
'**2XM<x>_Set the name of the '#039'main'#039' program routine (default i'+
's '#039'main'#039')'#010+
'**2Xn_Use target system native linker instead of GNU ld (Solaris, AIX)'+
#010+
'F*2Xp<x>_First search for the compiler binary in the directory <x>'#010+
'**2XP<x>_Prepend the binutil','s names with the prefix <x>'#010+
'F*2Xp<x>_First search for the',' compiler binary in the directory <x>'#010+
'**2XP<x>_Prepend the binutils names with the prefix <x>'#010+
'**2Xr<x>_Set the linker'#039's rlink-path to <x> (needed for cross comp'+
'ile, see the ld manual for more information) (BeOS, Linux)'#010+
'**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, FreeBSD'+
', Linux, Mac OS, ','Solaris)'#010+
'**2XR<x>_Prepend <x> ','to all linker search paths (BeOS, Darwin, FreeB'+
'SD, Linux, Mac OS, Solaris)'#010+
'**2Xs_Strip all symbols from executable'#010+
'**2XS_Try to link units statically (default, defines FPC_LINK_STATIC)'#010+
'**2Xt_Link with static libraries (-static is passed to linker)'#010+
'**2Xt_Link with static libraries (-static is passed to ','linker)'#010+
'**2Xv_Generate table for Virtual Entry calls'#010+
'**2XV_Use VLi','nk as external linker (default on Amiga, MorphOS)'+
#010+
'**2XV_Use VLink as external linker (default on Amiga, MorphOS)'#010+
'**2XX_Try to smartlink units (defines FPC_LINK_SMART)'#010+
'**1*_'#010+
'**1?_Show this help'#010+
'**1h_Shows this help without waiting'
'**1h_Shows this help witho','ut waiting'
);

4
compiler/nflw.pas
View File

@ -2179,7 +2179,7 @@ implementation
{ nested exits don't need the non local goto switch }
(labelsym.realname='$nestedexit') then
begin
if current_procinfo.procdef.parast.symtablelevel>labelsym.owner.symtablelevel then
if current_procinfo.procdef.parast.symtablelevel>=labelsym.owner.symtablelevel then
begin
{ don't mess with the exception blocks, global gotos in/out side exception blocks are not allowed }
if exceptionblock>0 then
@ -2212,7 +2212,7 @@ implementation
CGMessage1(cg_e_goto_label_not_found,labelsym.realname);
end
else
CGMessage(cg_e_interprocedural_goto_only_to_outer_scope_allowed);
CGMessagePos(self.fileinfo,cg_e_interprocedural_goto_only_to_outer_scope_allowed);
end
else
CGMessage1(cg_e_goto_label_not_found,labelsym.realname);

2
compiler/options.pas
View File

@ -1700,6 +1700,8 @@ begin
frameworksearchpath.AddPath(More,true)
else
IllegalPara(opt);
'F' :
RCForceFPCRes:=true;
'i' :
begin
if ispara then

3
compiler/rescmn.pas
View File

@ -65,6 +65,9 @@ uses
resflags : [res_external_file];
);
FPCResRCArgs = '--include $INC -of res -D FPC -o $RES $RC';
FPCResUtil = 'fpcres';
implementation

39
packages/fcl-base/examples/dbugsrv.pp
View File

@ -1,39 +0,0 @@
program dbugsrv;
{$MODE OBJFPC}
{$H+}
{$APPTYPE CONSOLE}
uses
classes,SysUtils,simpleipc,dbugmsg;
Var
Srv : TSimpleIPCServer;
S : String;
Msg : TDebugMessage;
begin
Srv:=TSimpleIPCServer.Create(Nil);
Try
Srv.ServerID:=DebugServerID;
Srv.Global:=True;
Srv.Active:=True;
Srv.StartServer;
Writeln('Server started. Listening for debug messages');
Repeat
If Srv.PeekMessage(1,True) then
begin
Srv.MsgData.Seek(0,soFrombeginning);
ReadDebugMessageFromStream(Srv.MsgData,MSg);
Write(FormatDateTime('hh:nn:ss.zzz',Msg.MsgTimeStamp),': ');
Write(DebugMessageName(MSg.MsgType):12,' ');
Writeln(Msg.Msg);
end
else
Sleep(10);
Until False;
Finally
Srv.Free;
end;
end.

6
packages/fcl-base/fpmake.pp
View File

@ -19,7 +19,6 @@ begin
{$endif ALLPACKAGES}
P.Version:='3.3.1';
P.Dependencies.Add('univint',[Darwin,iPhoneSim,ios]);
P.Dependencies.Add('fcl-res');
p.Dependencies.Add('rtl-objpas');
P.Author := '<various>';
@ -120,8 +119,6 @@ begin
T:=P.Targets.AddUnit('fpexprpars.pp');
T.ResourceStrings:=true;
T:=P.Targets.AddUnit('fileinfo.pp');
T.ResourceStrings:=true;
T:=P.Targets.AddUnit('csvreadwrite.pp');
T:=P.Targets.addUnit('csvdocument.pp');
With T.Dependencies do
@ -166,7 +163,6 @@ begin
T:=P.Targets.AddExampleProgram('poolmm1.pp');
T:=P.Targets.AddExampleProgram('poolmm2.pp');
T:=P.Targets.AddExampleProgram('restest.pp');
T:=P.Targets.AddExampleProgram('showver.pp');
T:=P.Targets.AddExampleProgram('sockcli.pp');
T:=P.Targets.AddExampleProgram('socksvr.pp');
T:=P.Targets.AddExampleProgram('sstream.pp');
@ -208,8 +204,6 @@ begin
// README
// kword.xml
// overview.rtf
// showver.rc
// showver.res
// simple.xml
// parser.dat
// testcgi.html

2
packages/fcl-base/src/fpexprpars.pp
View File

@ -896,7 +896,7 @@ Resourcestring
SErrCaseLabelNotAConst = 'Case label %d "%s" is not a constant expression';
SErrCaseLabelType = 'Case label %d "%s" needs type %s, but has type %s';
SErrCaseValueType = 'Case value %d "%s" needs type %s, but has type %s';
SErrDivisionByZero = '%d division by zero';
SErrDivisionByZero = '%s division by zero';
{ ---------------------------------------------------------------------
Auxiliary functions

0
packages/fcl-base/examples/showver.pp → packages/fcl-extra/examples/showver.pp
View File

0
packages/fcl-base/examples/showver.rc → packages/fcl-extra/examples/showver.rc
View File

0
packages/fcl-base/examples/showver.res → packages/fcl-extra/examples/showver.res
View File

12
packages/fcl-extra/fpmake.pp
View File

@ -19,6 +19,7 @@ begin
{$endif ALLPACKAGES}
P.Version:='3.3.1';
P.Dependencies.Add('fcl-base');
P.Dependencies.Add('fcl-res');
P.OSes:=[Win32,Win64]+AllUnixOSes;
if Defaults.CPU=jvm then
P.OSes := P.OSes - [java,android];
@ -47,10 +48,21 @@ begin
end;
T.ResourceStrings:=true;
T:=P.Targets.AddUnit('fileinfo.pp');
T.ResourceStrings:=true;
// Windows units
T:=P.Targets.AddUnit('ServiceManager.pas',[Win32,Win64]);
T.ResourceStrings:=true;
// Examples
P.ExamplePath.Add('examples');
T:=P.Targets.AddExampleProgram('showver.pp');
// example data files.
// showver.rc
// showver.res
{$ifndef ALLPACKAGES}
Run;
end;

0
packages/fcl-base/src/fileinfo.pp → packages/fcl-extra/src/fileinfo.pp
View File

4
packages/fcl-passrc/src/paswrite.pp
View File

@ -923,7 +923,9 @@ begin
// delphi compatible order for example: procedure foo; reintroduce; overload; static;
if not IsImpl and AProc.IsReintroduced then
Add(' reintroduce;');
if AProc.IsOverload and (Not FInImplementation) then
// if NamePrefix is not empty, we're writing a dummy for external class methods.
// In that case, we must not write the 'overload'.
if AProc.IsOverload and (NamePrefix='') then
Add(' overload;');
if not IsImpl then
begin

142
packages/fcl-process/examples/dbugsrv.pp Normal file
View File

@ -0,0 +1,142 @@
{
Make sure to set your project's options with, CompilerOptions --> Target "-o" -->Filename Value="fpcdebugserver",
i.e. the executable name must be the same as the client's const named dbugmsg.DebugServerID.
}
program dbugsrv;
{$MODE OBJFPC}
{$H+}
{$APPTYPE CONSOLE}
uses
classes,SysUtils,simpleipc,dbugmsg,strutils;
Type
{ THelperToWrite }
THelperToWrite = class
private
Class var StrLogFilename: string;
Class procedure WriteLnAllParams;
Class procedure InitParamsDependencies;
{ methods which override standard Write and WriteLn of the console output }
Class procedure DoWrite(const aBuffer: string);
Class procedure DoWrite(var aBuffer: string; const aMinimumFieldWidthIndent: integer); overload;
Class procedure DoWriteLn(const aBuffer: string);
{ methods which write in a log file, too }
Class procedure WriteNowThisLineInLog(aBuffer: string);
Class procedure WriteLnNowThisLineInLog(aBuffer: string);
Class function ReplaceSpecialCharsInLog(const aBuffer: string): string;
public
end;
Var
Srv : TSimpleIPCServer;
Msg : TDebugMessage;
StrBuffer : string = '';
ObjFileStream : TFileStream = Nil;
class procedure THelperToWrite.WriteLnAllParams;
Var
iNumParam: integer;
sBuffer: string;
begin
sBuffer := 'ParamCount='+IntToStr(ParamCount)+LineEnding;
for iNumParam := 0 to ParamCount do
sBuffer := IfThen(iNumParam<>ParamCount, sBuffer+'ParamStr('+IntToStr(iNumParam)+') = "'+ParamStr(iNumParam)+'"'+LineEnding, sBuffer+'ParamStr('+IntToStr(iNumParam)+') = "'+ParamStr(iNumParam)+'"');
THelperToWrite.DoWriteLn(sBuffer);
end;
class procedure THelperToWrite.InitParamsDependencies;
begin
If (ParamCount<>0) then
if ParamStr(1)<>'' then begin {ord. params: 1st is a log filename}
THelperToWrite.StrLogFilename:= ParamStr(1);
ObjFileStream:= TFileStream.Create(THelperToWrite.StrLogFilename, fmCreate or fmOpenWrite or fmShareDenyWrite);
ObjFileStream.Position:= 0;
end;
end;
class procedure THelperToWrite.DoWrite(const aBuffer: string);
begin
Write(aBuffer);
if Assigned(ObjFileStream) then THelperToWrite.WriteNowThisLineInLog(StrBuffer);
end;
class procedure THelperToWrite.DoWrite(var aBuffer: string; const aMinimumFieldWidthIndent: integer);
begin
Write(aBuffer:aMinimumFieldWidthIndent,' ');
if Assigned(ObjFileStream) then THelperToWrite.WriteNowThisLineInLog(StrBuffer);
end;
class procedure THelperToWrite.DoWriteLn(const aBuffer: string);
begin
WriteLn(aBuffer);
if Assigned(ObjFileStream) then THelperToWrite.WriteLnNowThisLineInLog(aBuffer+LineEnding)
end;
class procedure THelperToWrite.WriteNowThisLineInLog(aBuffer: string);
var
sBuffer: string;
begin
sBuffer:= THelperToWrite.ReplaceSpecialCharsInLog(aBuffer);
ObjFileStream.Write(sBuffer[1],length(sBuffer));
end;
class procedure THelperToWrite.WriteLnNowThisLineInLog(aBuffer: string);
var
sBuffer: string;
begin
aBuffer:= ' '{sep. each field of the msg-record}+aBuffer+LineEnding;
sBuffer:= THelperToWrite.ReplaceSpecialCharsInLog(aBuffer);
ObjFileStream.Write(sBuffer[1],length(sBuffer));
end;
class function THelperToWrite.ReplaceSpecialCharsInLog(const aBuffer: string): string;
begin
Result := StringsReplace(aBuffer, [LineEnding+LineEnding], [LineEnding], [rfReplaceAll]);
end;
ResourceString
SWelcomeOnSrv = 'IPC server started. Listening for debug messages:';
begin
Srv:=TSimpleIPCServer.Create(Nil);
Try
Srv.ServerID:=DebugServerID;
Srv.Global:=True;
Srv.Active:=True;
Srv.StartServer;
THelperToWrite.InitParamsDependencies;
THelperToWrite.WriteLnAllParams;
StrBuffer:=SWelcomeOnSrv;
THelperToWrite.DoWriteLn(StrBuffer);
Repeat
If Srv.PeekMessage(1,True) then
begin
Srv.MsgData.Seek(0,soFrombeginning);
ReadDebugMessageFromStream(Srv.MsgData,MSg);
StrBuffer:=FormatDateTime('hh:nn:ss.zzz',Msg.MsgTimeStamp)+': ';
THelperToWrite.DoWrite(StrBuffer);
StrBuffer:=DebugMessageName(MSg.MsgType);
THelperToWrite.DoWrite(StrBuffer,12);
StrBuffer:=Msg.Msg;
THelperToWrite.DoWriteLn(StrBuffer);
end
else
Sleep(10);
Until False;
Finally
if Assigned(ObjFileStream) then
ObjFileStream.Free;
Srv.Free;
end;
end.

54
packages/fcl-process/src/dbugintf.pp
View File

@ -19,8 +19,11 @@ unit dbugintf;
interface
uses dbugmsg;
Type
TDebugLevel = (dlInformation,dlWarning,dlError);
TErrorLevel = Array[TDebugLevel] of integer;
procedure SendBoolean(const Identifier: string; const Value: Boolean);
procedure SendDateTime(const Identifier: string; const Value: TDateTime);
@ -39,34 +42,33 @@ function GetDebuggingEnabled : Boolean;
{ low-level routines }
Function StartDebugServer : integer;
Function StartDebugServer(const aLogFilename : String = '') : integer;
Function InitDebugClient : Boolean;
Function InitDebugClient(const ShowOrNotPID: Boolean) : Boolean; overload;
function InitDebugClient(const ShowPID: Boolean; const ServerLogFilename: String = ''): Boolean;
procedure FreeDebugClient;
Const
SendError : String = '';
DefaultDebugServer = 'debugserver';
ResourceString
SProcessID = 'Process %s (PID=%d)';
SProcessID = '%d Process %s (PID=%d)';
SEntering = '> Entering ';
SExiting = '< Exiting ';
SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<';
SServerStartFailed = 'Failed to start debugserver. (%s)';
Var
DebugServerExe : String = DefaultDebugServer;
DebugServerExe : String = ''; { We can override this global var. in our compiled IPC client, with DefaultDebugServer a.k.a. dbugmsg.DebugServerID, or something else }
DefaultDebugServer : String = DebugServerID ; { A "last ressort" simplier compiled IPC server's name, called in command line by your client a.k.a. the compiler's target file "-o" }
SendError : String = '';
implementation
Uses
SysUtils, classes,dbugmsg, process, simpleipc;
SysUtils, classes, process, simpleipc, strutils;
Const
DmtInformation = lctInformation;
DmtWarning = lctWarning;
DmtError = lctError;
ErrorLevel : Array[TDebugLevel] of integer
ErrorLevel : TErrorLevel
= (dmtInformation,dmtWarning,dmtError);
IndentChars = 2;
@ -224,21 +226,23 @@ begin
Result := not DebugDisabled;
end;
function StartDebugServer : Integer;
function StartDebugServer(Const aLogFileName : string = '') : Integer;
Var
Cmd : string;
begin
Cmd:=DebugServerExe;
Cmd := DebugServerExe;
if Cmd='' then
Cmd:=DefaultDebugServer;
Cmd := DefaultDebugServer;
With TProcess.Create(Nil) do
begin
Try
CommandLine:=Cmd;
Executable := Cmd;
If aLogFileName<>'' Then
Parameters.Add(aLogFileName);
Execute;
Result:=ProcessID;
Result := ProcessID;
Except On E: Exception do
begin
SendError := Format(SServerStartFailed,[E.Message]);
@ -261,7 +265,7 @@ begin
begin
Msg.MsgType:=lctStop;
Msg.MsgTimeStamp:=Now;
Msg.Msg:=Format(SProcessID,[ApplicationName, GetProcessID]);
Msg.Msg:=Format(SProcessID,[GetProcessID, ApplicationName, GetProcessID]);
WriteMessage(Msg);
end;
if assigned(MsgBuffer) then FreeAndNil(MsgBuffer);
@ -272,17 +276,25 @@ end;
Function InitDebugClient : Boolean;
begin
InitDebugClient(False,'');
end;
function InitDebugClient(const ShowPID: Boolean; const ServerLogFilename: String = ''): Boolean;
Var
msg : TDebugMessage;
I : Integer;
begin
Result := False;
AlwaysDisplayPID:= ShowPID;
DebugClient:=TSimpleIPCClient.Create(Nil);
DebugClient.ServerID:=DebugServerID;
If not DebugClient.ServerRunning then
begin
ServerID:=StartDebugServer;
ServerID:=StartDebugServer(ServerLogFileName);
if ServerID = 0 then
begin
DebugDisabled := True;
@ -308,17 +320,11 @@ begin
MsgBuffer:=TMemoryStream.Create;
Msg.MsgType:=lctIdentify;
Msg.MsgTimeStamp:=Now;
Msg.Msg:=Format(SProcessID,[ApplicationName, GetProcessID]);
Msg.Msg:=Format(SProcessID,[GetProcessID, ApplicationName, GetProcessID]);
WriteMessage(Msg);
Result := True;
end;
function InitDebugClient(const ShowOrNotPID: Boolean): Boolean;
begin
AlwaysDisplayPID:= ShowOrNotPID;
Result:= InitDebugClient;
end;
Finalization
FreeDebugClient;
end.

2
packages/fcl-process/src/dbugmsg.pp
View File

@ -22,7 +22,7 @@ interface
uses Classes;
Const
DebugServerID : String = 'fpcdebugserver';
DebugServerID = 'fpcdebugserver'; { compiled IPC server's IDentifiant-name. Should be the same as the compiled IPC client dbugintf.DefaultDebugServer }
lctStop = -1;
lctInformation = 0;

27
packages/fcl-res/fpmake.pp
View File

@ -18,6 +18,9 @@ begin
P.Directory:=ADirectory;
{$endif ALLPACKAGES}
P.Version:='3.3.1';
P.Dependencies.Add('rtl-objpas');
P.Dependencies.Add('fcl-base');
P.Dependencies.Add('tplylib');
P.Author := 'Giulio Bernardi';
P.License := 'LGPL with modification, ';
P.HomepageURL := 'www.freepascal.org';
@ -189,6 +192,30 @@ begin
AddInclude('machosubwriter.inc');
AddInclude('machodefaulttarget.inc');
end;
T:=P.Targets.AddUnit('rcparser.pas');
with T.Dependencies do
begin
AddUnit('resource');
AddUnit('acceleratorsresource');
AddUnit('groupiconresource');
AddUnit('stringtableresource');
AddUnit('bitmapresource');
AddUnit('versionresource');
AddUnit('versiontypes');
AddUnit('groupcursorresource');
AddInclude('rcparserfn.inc');
AddInclude('rclex.inc');
AddInclude('yyinclude.pp');
AddInclude('yypreproc.pp');
end;
T:=P.Targets.AddUnit('rcreader.pp');
with T.Dependencies do
begin
AddUnit('resource');
AddUnit('resdatastream');
AddUnit('resfactory');
AddUnit('rcparser');
end;
T:=P.Targets.AddUnit('resdatastream.pp');
with T.Dependencies do
begin

1363
packages/fcl-res/src/rclex.inc Normal file
View File

File diff suppressed because it is too large Load Diff

121
packages/fcl-res/src/rclex.l Normal file
View File

@ -0,0 +1,121 @@
%{
var
kwtmp: integer;
const
KeywordDefs: array [0..33] of TIdentMapEntry = (
// attribs
(Value: _LANGUAGE; Name: 'LANGUAGE'),
(Value: _CHARACTERISTICS; Name: 'CHARACTERISTICS'),
(Value: _VERSION; Name: 'VERSION'),
(Value: _MOVEABLE; Name: 'MOVEABLE'),
(Value: _FIXED; Name: 'FIXED'),
(Value: _PURE; Name: 'PURE'),
(Value: _IMPURE; Name: 'IMPURE'),
(Value: _PRELOAD; Name: 'PRELOAD'),
(Value: _LOADONCALL; Name: 'LOADONCALL'),
(Value: _DISCARDABLE; Name: 'DISCARDABLE'),
// resource names
(Value: _ANICURSOR; Name: 'ANICURSOR'),
(Value: _ANIICON; Name: 'ANIICON'),
(Value: _BITMAP; Name: 'BITMAP'),
(Value: _CURSOR; Name: 'CURSOR'),
(Value: _DLGINCLUDE; Name: 'DLGINCLUDE'),
(Value: _DLGINIT; Name: 'DLGINIT'),
(Value: _HTML; Name: 'HTML'),
(Value: _ICON; Name: 'ICON'),
(Value: _MANIFEST; Name: 'MANIFEST'),
(Value: _MESSAGETABLE; Name: 'MESSAGETABLE'),
(Value: _PLUGPLAY; Name: 'PLUGPLAY'),
(Value: _STRINGTABLE; Name: 'STRINGTABLE'),
(Value: _RCDATA; Name: 'RCDATA'),
(Value: _VERSIONINFO; Name: 'VERSIONINFO'),
(Value: _VXD; Name: 'VXD'),
// file version fields names
(Value: _FILEVERSION; Name: 'FILEVERSION'),
(Value: _PRODUCTVERSION; Name: 'PRODUCTVERSION'),
(Value: _FILEFLAGSMASK; Name: 'FILEFLAGSMASK'),
(Value: _FILEFLAGS; Name: 'FILEFLAGS'),
(Value: _FILEOS; Name: 'FILEOS'),
(Value: _FILETYPE; Name: 'FILETYPE'),
(Value: _FILESUBTYPE; Name: 'FILESUBTYPE'),
(Value: _BLOCK; Name: 'BLOCK'),
(Value: _VALUE; Name: 'VALUE')
);
function KeywordToInt(k: string; out kw: integer): boolean;
var
i: integer;
begin
Result:= False;
for i:= low(KeywordDefs) to high(KeywordDefs) do begin
if k = KeywordDefs[i].Name then begin
kw:= KeywordDefs[i].Value;
Exit(True);
end;
end;
end;
%}
%x INCOMLINE INCOMMENT INSTRING INSTRINGL
O [0-7]
D [0-9]
H [0-9a-fA-F]
IDENT [a-zA-Z_]([a-zA-Z0-9_])*
%%
"//" start(INCOMLINE);
<INCOMLINE>\n begin start(0); unget_char(nl); end;
<INCOMLINE>. yymore;
"/*" start(INCOMMENT);
<INCOMMENT>. ;
<INCOMMENT>"*/" start(0);
<INCOMMENT>\0 return(_ILLEGAL);
{D}+L? return(_NUMBER);
0x{H}+L? return(_NUMBER);
0o{O}+L? return(_NUMBER);
L\" begin start(INSTRINGL); strbuf_begin(); end;
\" begin start(INSTRING); strbuf_begin(); end;
<INSTRING,INSTRINGL>\"\" strbuf_append('"');
<INSTRING>\" begin
start(0);
return(_QUOTEDSTR);
end;
<INSTRINGL>\" begin
start(0);
return(_QUOTEDSTRL);
end;
<INSTRING,INSTRINGL>\\\n ;
<INSTRING,INSTRINGL>\n return(_ILLEGAL);
<INSTRING,INSTRINGL>. strbuf_append(yytext);
\"StringFileInfo\" begin yytext:= 'StringFileInfo'; return(_STR_StringFileInfo); end;
\"VarFileInfo\" begin yytext:= 'VarFileInfo'; return(_STR_VarFileInfo); end;
\"Translation\" begin yytext:= 'Translation'; return(_STR_Translation); end;
BEGIN|{ return(_BEGIN);
END|} return(_END);
{IDENT} begin
if ypreproc.isdefine(yytext) then begin
unget_char(' ');
unget_string(ypreproc.getdefine(yytext));
end else
if KeywordToInt(yytext, kwtmp) then
return(kwtmp)
else
return(_ID);
end;
[ \t\n\f] ;
[,()|^&+-*/%~] returnc(yytext[1]);
. return(_ILLEGAL);
%%
// end.

2747
packages/fcl-res/src/rcparser.pas Normal file
View File

File diff suppressed because it is too large Load Diff

234
packages/fcl-res/src/rcparser.y Normal file
View File

@ -0,0 +1,234 @@
%{
(*
Vorspann
****************************************************************************)
unit rcparser;
{$I rcparserfn.inc}
%}
%token _ILLEGAL
%token _NUMBER _QUOTEDSTR _QUOTEDSTRL
%token _STR_StringFileInfo _STR_VarFileInfo _STR_Translation
%token _BEGIN _END _ID
%token _LANGUAGE _CHARACTERISTICS _VERSION _MOVEABLE _FIXED _PURE _IMPURE _PRELOAD _LOADONCALL _DISCARDABLE
%token _BITMAP _CURSOR _ICON _STRINGTABLE _VERSIONINFO
%token _ANICURSOR _ANIICON _DLGINCLUDE _DLGINIT _HTML _MANIFEST _MESSAGETABLE _PLUGPLAY _RCDATA _VXD
%token _FILEVERSION _PRODUCTVERSION _FILEFLAGSMASK _FILEFLAGS _FILEOS _FILETYPE _FILESUBTYPE _BLOCK _VALUE
%token _ACCELERATORS _DIALOG _DIALOGEX _MENU _MENUEX
%type <rcnumtype> numpos numexpr numeral
%type <rcstrtype> ident_string long_string
%type <TResourceDesc> resid rcdataid
%type <TMemoryStream> raw_data raw_item
%type <TFileStream> filename_string
%left '|'
%left '^'
%left '&'
%left '+' '-'
%left '*' '/' '%'
%right '~' _NUMNEG
%%
rcfile
: /* empty */
| rcfile defnstatement
;
defnstatement
: resourcedef
| languagedef
;
resourcedef
: res_stringtable
| res_bitmap
| res_cursor
| res_icon
| res_version
| res_rcdata
;
res_bitmap
: resid _BITMAP { create_resource($1, RT_BITMAP); } suboptions filename_string { TBitmapResource(aktresource).SetCustomBitmapDataStream($5); }
res_cursor
: resid _CURSOR { create_resource($1, RT_CURSOR); } suboptions filename_string { TGroupCursorResource(aktresource).SetCustomItemDataStream($5); }
res_icon
: resid _ICON { create_resource($1, RT_ICON); } suboptions filename_string { TGroupIconResource(aktresource).SetCustomItemDataStream($5); }
res_version
: resid _VERSIONINFO { create_resource($1, RT_VERSION); } version_fixed _BEGIN version_blocks _END
version_fixed
: /* empty */
| version_fixed _FILEVERSION numeral ',' numeral ',' numeral ',' numeral { TVersionResource(aktresource).FixedInfo.FileVersion:= make_version($3.v, $5.v, $7.v, $9.v); }
| version_fixed _PRODUCTVERSION numeral ',' numeral ',' numeral ',' numeral { TVersionResource(aktresource).FixedInfo.ProductVersion:= make_version($3.v, $5.v, $7.v, $9.v); }
| version_fixed _FILEFLAGSMASK numpos { TVersionResource(aktresource).FixedInfo.FileFlagsMask:= $3.v; }
| version_fixed _FILEFLAGS numpos { TVersionResource(aktresource).FixedInfo.FileFlags:= $3.v; }
| version_fixed _FILEOS numpos { TVersionResource(aktresource).FixedInfo.FileOS:= $3.v; }
| version_fixed _FILETYPE numpos { TVersionResource(aktresource).FixedInfo.FileType:= $3.v; }
| version_fixed _FILESUBTYPE numpos { TVersionResource(aktresource).FixedInfo.FileSubType:= $3.v; }
;
version_blocks
: /* empty */
| version_blocks _BLOCK _STR_StringFileInfo _BEGIN ver_strings_lang _END
| version_blocks _BLOCK _STR_VarFileInfo _BEGIN ver_translation_data _END
;
ver_strings_lang
: /* empty */
| ver_strings_lang _BLOCK long_string _BEGIN { version_string_tab_begin($3.v^); }
ver_strings_data _END
;
ver_strings_data
: /* empty */
| ver_strings_data _VALUE long_string ',' long_string { version_string_tab_add($3.v^, $5.v^); }
;
ver_translation_data
: _VALUE _STR_Translation ',' ver_translation_pair
;
ver_translation_pair
: numeral ',' numeral { version_var_translation_add($1.v, $3.v); }
| ver_translation_pair ',' numeral ',' numeral { version_var_translation_add($3.v, $5.v); }
;
res_rcdata
: resid rcdataid { create_resource($1, $2); } suboptions filename_string { aktresource.SetCustomRawDataStream($5); }
| resid rcdataid { create_resource($1, $2); } suboptions _BEGIN raw_data _END { aktresource.SetCustomRawDataStream($6); }
;
res_stringtable
: _STRINGTABLE { stringtable_begin(); } suboptions _BEGIN stringtable_data _END { stringtable_end(); }
stringtable_data
: /* empty */
| stringtable_data stringtable_entry
;
stringtable_entry
: numeral ',' long_string { stringtable_add($1.v, $3.v^); }
| numeral long_string { stringtable_add($1.v, $2.v^); }
;
rcdataid
: _ANICURSOR { $$:= TResourceDesc.Create(RT_ANICURSOR); }
| _ANIICON { $$:= TResourceDesc.Create(RT_ANIICON); }
| _DLGINCLUDE { $$:= TResourceDesc.Create(RT_DLGINCLUDE); }
| _DLGINIT { $$:= TResourceDesc.Create(RT_DLGINIT); }
| _HTML { $$:= TResourceDesc.Create(23); }
| _MANIFEST { $$:= TResourceDesc.Create(RT_MANIFEST); }
| _MESSAGETABLE { $$:= TResourceDesc.Create(RT_MESSAGETABLE); }
| _PLUGPLAY { $$:= TResourceDesc.Create(RT_PLUGPLAY); }
| _RCDATA { $$:= TResourceDesc.Create(RT_RCDATA); }
| _VXD { $$:= TResourceDesc.Create(RT_VXD); }
| resid
;
resid
: numpos { $$:= TResourceDesc.Create($1.v); }
| ident_string { $$:= TResourceDesc.Create($1.v^); }
;
suboptions
: /* empty */
| suboptions suboption
;
suboption
: _LANGUAGE numpos ',' numpos { change_lang_id(MakeLangID($2.v, $4.v)); }
| _CHARACTERISTICS numpos { aktresource.Characteristics:= $2.v; }
| _VERSION numpos { aktresource.Version:= $2.v; }
| _MOVEABLE { aktresource.MemoryFlags:= aktresource.MemoryFlags or MF_MOVEABLE; }
| _FIXED { aktresource.MemoryFlags:= aktresource.MemoryFlags and not MF_MOVEABLE; }
| _PURE { aktresource.MemoryFlags:= aktresource.MemoryFlags or MF_PURE; }
| _IMPURE { aktresource.MemoryFlags:= aktresource.MemoryFlags and not MF_PURE; }
| _PRELOAD { aktresource.MemoryFlags:= aktresource.MemoryFlags or MF_PRELOAD; }
| _LOADONCALL { aktresource.MemoryFlags:= aktresource.MemoryFlags and not MF_PRELOAD; }
| _DISCARDABLE { aktresource.MemoryFlags:= aktresource.MemoryFlags or MF_DISCARDABLE; }
;
languagedef
: _LANGUAGE numpos ',' numpos { language:= MakeLangID($2.v, $4.v); }
numpos
: numexpr
;
numeral
: _NUMBER { $$:= str_to_num(yytext); }
;
numexpr
: numeral
| '(' numexpr ')' { $$:= $2; }
| '~' numexpr %prec '~' { $$.v:= not $2.v; $$.long:= $2.long; }
| '-' numexpr %prec _NUMNEG { $$.v:= -$2.v; $$.long:= $2.long; }
| numexpr '*' numexpr { $$.v:= $1.v * $3.v; $$.long:= $1.long or $3.long; }
| numexpr '/' numexpr { $$.v:= $1.v div Max(1, $3.v); $$.long:= $1.long or $3.long; }
| numexpr '%' numexpr { $$.v:= $1.v mod Max(1, $3.v); $$.long:= $1.long or $3.long; }
| numexpr '+' numexpr { $$.v:= $1.v + $3.v; $$.long:= $1.long or $3.long; }
| numexpr '-' numexpr { $$.v:= $1.v - $3.v; $$.long:= $1.long or $3.long; }
| numexpr '&' numexpr { $$.v:= $1.v and $3.v; $$.long:= $1.long or $3.long; }
| numexpr '^' numexpr { $$.v:= $1.v xor $3.v; $$.long:= $1.long or $3.long; }
| numexpr '|' numexpr { $$.v:= $1.v or $3.v; $$.long:= $1.long or $3.long; }
;
ident_string
: _ID { string_new($$, yytext, opt_code_page); }
| long_string
;
filename_string
: long_string { $$:= TFileStream.Create($1.v^, fmOpenRead or fmShareDenyWrite); }
;
long_string
: _QUOTEDSTR { string_new_uni($$, @strbuf[0], strbuflen, opt_code_page, true); }
| _QUOTEDSTRL { string_new_uni($$, @strbuf[0], strbuflen, CP_UTF16, true); }
| _STR_StringFileInfo { string_new($$, yytext, opt_code_page); }
| _STR_VarFileInfo { string_new($$, yytext, opt_code_page); }
| _STR_Translation { string_new($$, yytext, opt_code_page); }
;
raw_data
: { $$:= TMemoryStream.Create; }
raw_item
| raw_data ',' { $$:= $1; } raw_item
;
raw_item
: /* empty */
{
$$:= $<TMemoryStream>0;
}
| long_string
{
$$:= $<TMemoryStream>0;
raw_write_string($$, $1);
}
| numeral
{
$$:= $<TMemoryStream>0;
raw_write_int($$, $1);
}
;
%%
{$I rclex.inc}
begin
bufptr:= 0;
lexlib.get_char:= @rc_get_char;
lexlib.unget_char:= @rc_unget_char;
end.

435
packages/fcl-res/src/rcparserfn.inc Normal file
View File

@ -0,0 +1,435 @@
{%MainUnit rcparser.pas}
interface
{$mode objfpc}{$H+}
{$COPERATORS ON}
{$GOTO ON}
uses
SysUtils, Classes, StrUtils, fgl, lexlib, yacclib, resource,
acceleratorsresource, groupiconresource, stringtableresource,
bitmapresource, versionresource, versiontypes, groupcursorresource;
type
TStringHashTable = specialize TFPGMap<String, String>;
function yyparse : Integer;
var
aktresources: TResources;
opt_code_page: TSystemCodePage;
yyfilename: AnsiString;
yyparseresult: YYSType;
procedure DisposePools;
procedure SetDefaults;
procedure PragmaCodePage(cp: string);
{$DEFINE INC_HEADER}
{$I yyinclude.pp}
{$I yypreproc.pp}
{$UNDEF INC_HEADER}
implementation
procedure yyerror ( msg : String );
begin
writeln(ErrOutput, yyfilename, '(',yylineno,':',yycolno,'): at "',yytext,'": ', msg);
WriteLn(ErrOutput, yyline);
WriteLn(ErrOutput, '^':yycolno);
end(*yyerrmsg*);
{$I yyinclude.pp}
{$I yypreproc.pp}
(* I/O routines: *)
const nl = #10; (* newline character *)
const max_chars = 2048;
var
bufptr : Integer;
buf : array [1..max_chars] of Char;
function rc_get_char : Char;
var i : Integer;
ok : boolean;
begin
if (bufptr=0) and not eof(yyinput) then
begin
repeat
readln(yyinput, yyline);
inc(yylineno); yycolno := 1;
ok:= ypreproc.useline(yyline);
until (ok or eof(yyinput));
if ok then begin
buf[1] := nl;
for i := 1 to length(yyline) do
buf[i+1] := yyline[length(yyline)-i+1];
inc(bufptr, length(yyline)+1);
end;
end;
if bufptr>0 then
begin
rc_get_char := buf[bufptr];
dec(bufptr);
inc(yycolno);
end
else
rc_get_char := #0;
end(*get_char*);
procedure rc_unget_char ( c : Char );
begin
if bufptr=max_chars then yyerror('input buffer overflow');
inc(bufptr);
dec(yycolno);
buf[bufptr] := c;
end(*unget_char*);
procedure unget_string(s: string);
var
i: integer;
begin
for i:= Length(s) downto 1 do
rc_unget_char(s[i]);
end;
procedure PragmaCodePage(cp: string);
var cpi: integer;
begin
if Uppercase(cp) = 'DEFAULT' then
opt_code_page:= DefaultFileSystemCodePage
else begin
if TryStrToInt(cp, cpi) and (cpi>=0) and (cpi<=high(TSystemCodePage)) then
opt_code_page:= cpi
else
yyerror('Invalid code_page pragma: "' + cp + '"');
end;
end;
type
rcnumtype = record
v: LongWord;
long: boolean;
end;
rcstrtype = record
v: PUnicodeString;
cp: TSystemCodePage;
end;
function str_to_cbase(s: string): LongWord;
begin
if s = '0' then
Exit(0);
if Copy(s, 1, 2) = '0x' then
Exit(StrToInt('$' + Copy(s, 3, Maxint)));
if Copy(s, 1, 2) = '0o' then
Exit(StrToInt('&' + Copy(s, 3, Maxint)));
if Copy(s, 1, 1) = '0' then
Exit(StrToInt('&' + Copy(s, 2, Maxint)));
Result:= StrToInt(s);
end;
function str_to_num(s:string): rcnumtype;
begin
// this does not handle empty strings - should never get them from the lexer
Result.long:= s[Length(s)] = 'L';
if Result.long then
setlength(s, Length(s) - 1);
Result.v:= str_to_cbase(s);
end;
type
PStrPoolItem = ^TStrPoolItem;
TStrPoolItem = record
str: PUnicodeString;
next: PStrPoolItem;
end;
const
MAX_RCSTR_LEN = 4096;
var
strbuf: array[0..MAX_RCSTR_LEN + 1] of char;
strbuflen: Integer;
stringpool: PStrPoolItem = nil;
procedure strbuf_begin();
begin
FillChar(strbuf[0], sizeof(strbuf), 0);
strbuflen:= 0;
end;
procedure strbuf_append(s: string);
var
rem: integer;
begin
rem:= MAX_RCSTR_LEN - strbuflen;
if Length(s) < rem then
rem:= Length(s);
Move(s[1], strbuf[strbuflen], rem);
inc(strbuflen, rem);
end;
procedure string_new(var str: rcstrtype; val: UnicodeString; cp: TSystemCodePage);
var
s: PStrPoolItem;
begin
New(str.v);
str.v^:= val;
str.cp:= cp;
New(s);
s^.next:= stringpool;
s^.str:= str.v;
stringpool:= s;
end;
procedure string_new_uni(var str: rcstrtype; val: PAnsiChar; len: integer; cp: TSystemCodePage; escapes: boolean);
function translateChar(c: AnsiChar): UnicodeChar;
var
u: UnicodeString = '';
begin
if cp = CP_UTF16 then
Result:= c
else begin
// TODO: there has to be a better way to translate a single codepoint
widestringmanager.Ansi2UnicodeMoveProc(@c, cp, u, 1);
Result:= u[1];
end;
end;
var
uni: UnicodeString;
wc: PUnicodeChar;
rc, endin: PAnsiChar;
h: string;
hexlen, i: integer;
begin
uni:= '';
if not escapes then
widestringmanager.Ansi2UnicodeMoveProc(val, cp, uni, len)
else begin
if cp = CP_UTF16 then
hexlen:= 4
else
hexlen:= 2;
setlength(uni, len);
wc:= @uni[1];
rc:= val;
endin:= @val[len];
while rc < endin do begin
if (rc^ = '\') then begin
inc(rc);
case rc^ of
#0: exit {Error: End too soon};
'\': wc^:= '\';
'f': wc^:= #&14;
'n': wc^:= #&12;
'r': wc^:= #&15;
't': wc^:= #&11;
'x',
'X': begin
h:= '$';
for i:= 1 to hexlen do begin
inc(rc);
if rc >= endin then
exit {Error: End too soon};
h += rc^;
end;
if cp = CP_UTF16 then
wc^:= WideChar(StrToInt(h))
else
wc^:= translateChar(Char(StrToInt(h)));
end;
'0'..'7': begin
h:= '&' + rc^;
for i:= 2 to 3 do begin
inc(rc);
if (rc >= endin) or not (rc^ in ['0'..'7']) then begin
dec(rc);
break;
end;
h += rc^;
end;
if cp = CP_UTF16 then
wc^:= WideChar(StrToInt(h))
else
wc^:= translateChar(Char(StrToInt(h)));
end;
else
wc^:= translateChar(rc^);
end;
end else
wc^:= translateChar(rc^);
inc(wc);
inc(rc);
end;
i:= (PtrUInt(wc) - PtrUInt(@uni[1])) div SizeOf(WideChar);
SetLength(uni, i);
end;
string_new(str, uni, cp);
end;
function Max(a, b: LongWord): LongWord; inline;
begin
if a > b then
Result:= a
else
Result:= b;
end;
var
aktresource: TAbstractResource;
language: TLangID;
procedure create_resource(aId, aType: TResourceDesc; aClass: TResourceClass);
var
r: TAbstractResource;
begin
r:= aClass.Create(aType, aId);
r.LangID:= language;
aktresources.Add(r);
aktresource:= r;
aId.Free;
aType.Free;
end;
procedure create_resource(aId, aType: TResourceDesc); overload;
begin
create_resource(aId, aType, TGenericResource);
end;
procedure create_resource(aId: TResourceDesc; aType: Word); overload;
var
cls: TResourceClass;
begin
case aType of
RT_BITMAP: cls:= TBitmapResource;
RT_ICON: cls:= TGroupIconResource;
RT_CURSOR: cls:= TGroupCursorResource;
RT_VERSION: cls:= TVersionResource;
else
raise EResourceDescTypeException.CreateFmt('Resource type not supported: %d', [aType]);
end;
create_resource(aId, nil, cls);
end;
procedure change_lang_id(newlang: TLangID);
begin
// cannot change a language id while it is contained in a list, so remove and re-add
aktresources.Remove(aktresource);
aktresource.LangID:= newlang;
aktresources.Add(aktresource);
end;
procedure raw_write_string(Stream: TMemoryStream; str: rcstrtype);
var
i: integer;
u: UnicodeString;
r: RawByteString = '';
begin
u:= str.v^;
if str.cp = CP_UTF16 then begin
for i:=1 to length(u) do
Stream.WriteWord(NtoLE(Word(u[i])));
end else begin
widestringmanager.Unicode2AnsiMoveProc(@u[1], r, str.cp, Length(u));
Stream.WriteBuffer(r[1], Length(r));
end;
end;
procedure raw_write_int(Stream: TMemoryStream; num: rcnumtype);
begin
if num.long then
Stream.WriteDWord(NtoLE(num.v))
else
Stream.WriteWord(NtoLE(Word(num.v)));
end;
procedure stringtable_begin();
begin
// create dummy resource that we will use to capture suboptions
create_resource(TResourceDesc.create(1), TResourceDesc.create(1));
aktresources.Remove(aktresource);
end;
procedure stringtable_add(ident: Word; str: AnsiString);
var
table: word;
r: TStringTableResource;
begin
table:= (ident div 16) + 1;
try
{ TODO : This is stupid }
r:= aktresources.Find(RT_STRING, table, aktresource.LangID) as TStringTableResource;
except
on e: EResourceNotFoundException do begin
r:= TStringTableResource.Create;
r.LangID:= aktresource.LangID;
r.MemoryFlags:= aktresource.MemoryFlags;
r.Characteristics:= aktresource.Characteristics;
r.Version:= aktresource.Version;
r.FirstID:= ident;
aktresources.Add(r);
end;
end;
r.Strings[ident]:= str;
end;
procedure stringtable_end();
begin
FreeAndNil(aktresource);
end;
function make_version(a, b, c, d: Word): TFileProductVersion;
begin
Result[0]:= a;
Result[1]:= b;
Result[2]:= c;
Result[3]:= d;
end;
procedure version_string_tab_begin(lcs: AnsiString);
var
vst: TVersionStringTable;
begin
vst:= TVersionStringTable.Create(lcs);
TVersionResource(aktresource).StringFileInfo.Add(vst);
end;
procedure version_string_tab_add(key, value: AnsiString);
begin
TVersionResource(aktresource).StringFileInfo.Items[TVersionResource(aktresource).StringFileInfo.Count-1].Add(key, value);
end;
procedure version_var_translation_add(langid, cpid: word);
var
ti: TVerTranslationInfo;
begin
ti.language:= langid;
ti.codepage:= cpid;
TVersionResource(aktresource).VarFileInfo.Add(ti);
end;
procedure SetDefaults;
begin
language:= $0409; // MS RC starts up as en-US
PragmaCodePage('DEFAULT');
end;
procedure DisposePools;
var
s: PStrPoolItem;
begin
while stringpool <> nil do begin
s:= stringpool;
stringpool:= s^.next;
dispose(s^.str);
dispose(s);
end;
end;

133
packages/fcl-res/src/rcreader.pp Normal file
View File

@ -0,0 +1,133 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2008 by Giulio Bernardi
Resource reader/compiler for MS RC script files
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit rcreader;
{$MODE OBJFPC} {$H+}
interface
uses
Classes, SysUtils, resource;
type
{ TRCResourceReader }
TRCResourceReader = class(TAbstractResourceReader)
private
fExtensions : string;
fDescription : string;
fRCIncludeDirs: TStringList;
fRCDefines: TStringList;
protected
function GetExtensions : string; override;
function GetDescription : string; override;
procedure Load(aResources : TResources; aStream : TStream); override;
function CheckMagic(aStream : TStream) : boolean; override;
procedure ReadRCFile(aResources : TResources; aLocation: String; aStream : TStream);
public
constructor Create; override;
destructor Destroy; override;
property RCIncludeDirs: TStringList read fRCIncludeDirs;
property RCDefines: TStringList read fRCDefines;
end;
implementation
uses
StreamIO, resdatastream, resfactory, lexlib, rcparser;
{ TRCResourceReader }
function TRCResourceReader.GetExtensions: string;
begin
Result:=fExtensions;
end;
function TRCResourceReader.GetDescription: string;
begin
Result:=fDescription;
end;
procedure TRCResourceReader.Load(aResources: TResources; aStream: TStream);
var
fd: String;
begin
if aStream is TFileStream then
fd:= ExtractFilePath(TFileStream(aStream).FileName)
else
fd:= IncludeTrailingPathDelimiter(GetCurrentDir);
try
ReadRCFile(aResources, fd, aStream);
except
on e : EReadError do
raise EResourceReaderUnexpectedEndOfStreamException.Create('');
end;
end;
function TRCResourceReader.CheckMagic(aStream: TStream): boolean;
begin
{ TODO : Check for Text-Only file }
Result:= True;
end;
procedure TRCResourceReader.ReadRCFile(aResources: TResources; aLocation: String; aStream: TStream);
var
i: Integer;
begin
AssignStream(lexlib.yyinput, aStream);
Reset(lexlib.yyinput);
try
rcparser.yyfilename:= '#MAIN.RC';
rcparser.SetDefaults;
SetTextCodePage(lexlib.yyinput, rcparser.opt_code_page);
rcparser.yinclude:= tyinclude.Create;
rcparser.yinclude.WorkDir:= aLocation;
rcparser.yinclude.SearchPaths.Assign(fRCIncludeDirs);
rcparser.ypreproc:= typreproc.Create;
rcparser.ypreproc.Defines.Add('RC_INVOKED', '');
for i:= 0 to fRCDefines.Count-1 do
rcparser.ypreproc.Defines.KeyData[fRCDefines.Names[i]]:= fRCDefines.ValueFromIndex[i];
rcparser.aktresources:= aResources;
if rcparser.yyparse <> 0 then
raise EReadError.Create('Parse Error');
finally
rcparser.DisposePools;
FreeAndNil(rcparser.ypreproc);
FreeAndNil(rcparser.yinclude);
end;
end;
constructor TRCResourceReader.Create;
begin
fExtensions:='.rc';
fDescription:='RC script resource reader';
fRCDefines:= TStringList.Create;
fRCIncludeDirs:= TStringList.Create;
end;
destructor TRCResourceReader.Destroy;
begin
fRCIncludeDirs.Free;
fRCDefines.Free;
inherited;
end;
initialization
{ don't register automatically, as this is essentially a "catch all" }
//TResources.RegisterReader('.rc',TRCResourceReader);
end.

1
packages/fcl-res/src/resource.pp
View File

@ -44,6 +44,7 @@ const
RT_ANIICON = 22; //Animated icon.
RT_HTML = 23; //HTML.
RT_MANIFEST = 24; //Microsoft Windows XP: Side-by-Side Assembly XML Manifest.
RT_DLGINIT = 240; //Never present in compiled form
CREATEPROCESS_MANIFEST_RESOURCE_ID = 1;
ISOLATIONAWARE_MANIFEST_RESOURCE_ID = 2;

56
packages/fcl-res/src/stringtableresource.pp
View File

@ -21,13 +21,13 @@ interface
uses
Classes, SysUtils, resource;
type
EStringTableResourceException = class(EResourceException);
EStringTableNameNotAllowedException = class(EStringTableResourceException);
EStringTableIndexOutOfBoundsException = class(EStringTableResourceException);
resourcestring
SNameNotAllowed = 'Resource ID must be an ordinal in the range 1-4096';
SIndexOutOfBounds = 'String ID out of bounds: %d';
@ -42,7 +42,7 @@ type
fName : TResourceDesc;
fFirstID : word;
fCount : integer;
fList : TStringList;
fList : array of UnicodeString;
fCanChangeDesc : boolean;
function IDtoIndex(const aId : word) : integer;
procedure CheckListLoaded;
@ -85,54 +85,47 @@ end;
procedure TStringTableResource.CheckListLoaded;
var i : integer;
begin
if fList<>nil then exit;
fList:=TStringList.Create;
fList.Capacity:=16;
if Length(fList) <> 0 then exit;
SetLength(fList, fCount);
for i:=0 to high(fList) do
fList[i]:= '';
if RawData.Size=0 then exit;
RawData.Position:=0;
for i:=0 to 15 do
fList.Add(ReadWideString);
for i:=0 to high(fList) do
fList[i]:= ReadWideString;
end;
function TStringTableResource.ReadWideString: string;
var ws : widestring;
var ws : unicodestring;
w : word;
i : integer;
begin
RawData.ReadBuffer(w,2);
{$IFDEF ENDIAN_BIG}
w:=SwapEndian(w);
{$ENDIF}
w:= LEtoN(w);
setlength(ws,w);
for i:=1 to length(ws) do
begin
RawData.ReadBuffer(w,2);
{$IFDEF ENDIAN_BIG}
w:=SwapEndian(w);
{$ENDIF}
w:= LEtoN(w);
ws[i]:=widechar(w);
end;
Result:=ws;
end;
procedure TStringTableResource.WriteWideString(const aString: string);
var ws : widestring;
var ws : unicodestring;
w : word;
i : integer;
begin
w:=length(aString);
{$IFDEF ENDIAN_BIG}
w:=SwapEndian(w);
{$ENDIF}
w:= NtoLE(w);
RawData.WriteBuffer(w,2);
ws:=aString;
for i:=1 to length(ws) do
begin
w:=word(ws[i]);
{$IFDEF ENDIAN_BIG}
w:=SwapEndian(w);
{$ENDIF}
w:= NtoLE(w);
RawData.WriteBuffer(w,2);
end;
end;
@ -157,8 +150,8 @@ begin
CheckIndex(id);
CheckListLoaded;
idx:=IDtoIndex(id);
if idx>=fList.Count then Result:=''
else Result:=fList[idx];
if idx>high(fList) then Result:= ''
else Result:= fList[idx];
end;
procedure TStringTableResource.SetString(id: word; aString: string);
@ -167,13 +160,7 @@ begin
CheckIndex(id);
CheckListLoaded;
idx:=IDtoIndex(id);
if idx<fList.Count then fList[idx]:=aString
else if idx>=fList.Count then
begin
for i:=fList.Count to idx-1 do
fList.Add('');
fList.Add(aString);
end;
fList[idx]:= aString;
end;
procedure TStringTableResource.UpdateRawData;
@ -184,7 +171,7 @@ begin
RawData.Position:=0;
for i:=FirstID to LastID do
WriteWideString(Strings[i]);
FreeAndNil(fList);
fList:= nil;
end;
function TStringTableResource.GetType: TResourceDesc;
@ -223,7 +210,7 @@ constructor TStringTableResource.Create;
begin
inherited Create;
fCanChangeDesc:=false;
fList:=nil;
fList:= nil;
fType:=TResourceDesc.Create(RT_STRING);
fName:=TResourceDesc.Create(1);
fCount:=16;
@ -248,8 +235,7 @@ destructor TStringTableResource.Destroy;
begin
fType.Free;
fName.Free;
if fList<>nil then
fList.Free;
SetLength(fList, 0);
inherited Destroy;
end;

127
packages/fcl-res/src/yyinclude.pp Normal file
View File

@ -0,0 +1,127 @@
{%MainUnit rcparser.pas}
{$IFDEF INC_HEADER}
type
tyinclude = class
const
yi_maxlevels = 5;
var
stack: array[0..yi_maxlevels] of record
yyinput : Text; (* input and output file *)
yyline : String; (* current input line *)
yylineno, yycolno : Integer; (* current input position *)
fn : AnsiString;
prev_wrap : yywrap_t;
end;
level: integer;
WorkDir: string;
SearchPaths: TStringList;
public
constructor Create;
destructor Destroy; override;
class function wrapone(): Boolean; static;
function push(const incfile: ansistring): Boolean;
function pop(): Boolean;
function expand(fn: AnsiString): AnsiString;
end;
var
yinclude: tyinclude;
{$ELSE}
class function tyinclude.wrapone(): Boolean;
begin
Result:= yinclude.pop;
end;
function tyinclude.push(const incfile: ansistring): Boolean;
begin
stack[level].yyinput:= yyinput;
stack[level].yyline:= yyline;
stack[level].yylineno:= yylineno;
stack[level].yycolno:= yycolno;
stack[level].prev_wrap:= yywrap;
stack[level].fn:= yyfilename;
inc(level);
yywrap:= @tyinclude.wrapone;
AssignFile(yyinput, incfile);
Reset(yyinput);
yyfilename:= incfile;
yyline:= '';
yylineno:= 0;
yycolno:= 0;
{$if declared(ypreproc)}
ypreproc.newfile(yyfilename);
{$endif}
Result:= true;
end;
function tyinclude.pop(): Boolean;
begin
Close(yyinput);
Result:= level = 0;
if not Result then begin
Dec(level);
yyinput:= stack[level].yyinput;
yyline:= stack[level].yyline;
yylineno:= stack[level].yylineno;
yycolno:= stack[level].yycolno;
yywrap:= stack[level].prev_wrap;
yyfilename:= stack[level].fn;
{$if declared(ypreproc)}
ypreproc.newfile(yyfilename);
{$endif}
end;
end;
function tyinclude.expand(fn: AnsiString): AnsiString;
var
i: integer;
f: string;
begin
result:= '';
if Length(fn) > 3 then begin
if (fn[1] = '<') and (fn[length(fn)] = '>') then begin
fn:= copy(fn, 2, Length(fn)-2);
for i:= 0 to SearchPaths.Count - 1 do begin
f:= ConcatPaths([SearchPaths[i], fn]);
if FileExists(f) then
Exit(f);
end;
yyerror('Include file not found on search paths: <'+fn+'>');
end
else if (fn[1] = '"') and (fn[length(fn)] = '"') then begin
fn:= copy(fn, 2, Length(fn)-2);
f:= ConcatPaths([WorkDir, fn]);
if FileExists(f) then
Exit(f);
if fn = 'windows.h' then begin
// treat windows.h as an alias for windres.h
f:= ConcatPaths([WorkDir, 'windres.h']);
if FileExists(f) then
Exit(f);
end;
yyerror('Include file not found: "'+fn+'"');
end;
end;
yyerror('Invalid include directive: "'+fn+'"');
end;
constructor tyinclude.Create;
begin
inherited Create;
level:= 0;
WorkDir:= GetCurrentDir;
SearchPaths:= TStringList.Create;
end;
destructor tyinclude.Destroy;
begin
FreeAndNil(SearchPaths);
inherited;
end;
{$ENDIF}

160
packages/fcl-res/src/yypreproc.pp Normal file
View File

@ -0,0 +1,160 @@
{%MainUnit rcparser.pas}
{$IFDEF INC_HEADER}
type
typreproc = class
const
yp_maxlevels = 16;
var
Defines: TStringHashTable;
skip : array[0..yp_maxlevels-1] of boolean;
cheadermode: boolean;
level : longint;
public
constructor Create;
destructor Destroy; override;
function isdefine(ident: string): boolean;
function getdefine(ident: string): string;
function useline(line: string): boolean;
procedure newfile(fn: string);
end;
var
ypreproc: typreproc;
{$ELSE}
constructor typreproc.Create;
begin
inherited Create;
Defines:= TStringHashTable.Create;
level:= 0;
cheadermode:= false;
fillchar(skip,sizeof(skip),0);
end;
destructor typreproc.Destroy;
begin
FreeAndNil(Defines);
inherited;
end;
function Copy2SpaceDelTrim(var s: string): string;
const
whitespace = [#9, ' '];
var
p: integer;
begin
p:= PosSet(whitespace, s);
if p <= 0 then begin
result:= s;
s:= '';
end else begin
result:= Copy(S, 1, p-1);
while (p < Length(s)) and (s[p] in whitespace) do
inc(p);
Delete(s, 1, p-1);
end;
end;
function Substring(s: string; First, Last: integer): string;
begin
Result:= Copy(s, First, Last-First+1);
end;
function typreproc.isdefine(ident: string): boolean;
begin
Result:= Defines.IndexOf(ident) >= 0;
end;
function typreproc.getdefine(ident: string): string;
begin
Result:= Defines[ident];
end;
function typreproc.useline(line: string): boolean;
var
w, word, arg1: string;
begin
Result:= true;
w:= trim(line);
if (yystate <= 1) and
(Length(w) > 2) and (w[1] = '#') then begin
Delete(w, 1, 1);
word:= Copy2SpaceDelTrim(w);
case word of
'ifdef': begin
inc(Level);
if Level >= yp_maxlevels then begin
yyerror('Too many ifdef levels');
exit;
end;
skip[level]:= (skip[level-1] or (not isdefine(w)));
end;
'ifndef': begin
inc(Level);
if Level >= yp_maxlevels then begin
yyerror('Too many ifdef levels');
exit;
end;
skip[level]:= (skip[level-1] or (isdefine(w)));
end;
'if': begin
inc(Level);
if Level >= yp_maxlevels then begin
yyerror('Too many ifdef levels');
exit;
end;
{ TODO : implement some expressions? for now, always returns false }
skip[level]:= (skip[level-1] or False);
end;
'else': begin
skip[level]:= skip[level-1] or (not skip[level]);
end;
'endif': begin
skip[level]:= false;
if Level = 0 then begin
yyerror('Too many endif found');
exit;
end;
dec(level);
end;
else
if not skip[level] then
case word of
'pragma': begin
if StartsStr('code_page(', w) then begin
arg1:= Substring(w, Length('code_page(') + 1, Pos(')', w) - 1);
PragmaCodePage(arg1);
end;
end;
'define': begin
arg1:= Copy2SpaceDelTrim(w);
Defines[arg1]:= w;
end;
'undef': begin
Defines.Remove(w);
end;
'include': begin
arg1:= yinclude.expand(w);
yinclude.push(arg1);
end;
end;
end;
Result:= false;
end else begin
Result:= (not cheadermode) and (not skip[level]);
end;
end;
procedure typreproc.newfile(fn: string);
var
ex: String;
begin
ex:= UpperCase(ExtractFileExt(yyfilename));
cheadermode:= (ex = '.C') or (ex = '.H');
end;
{$ENDIF}

1
packages/fpmake_add.inc
View File

@ -118,6 +118,7 @@
add_syslog(ADirectory+IncludeTrailingPathDelimiter('syslog'));
add_tcl(ADirectory+IncludeTrailingPathDelimiter('tcl'));
add_tosunits(ADirectory+IncludeTrailingPathDelimiter('tosunits'));
add_tplylib(ADirectory+IncludeTrailingPathDelimiter('tplylib'));
add_univint(ADirectory+IncludeTrailingPathDelimiter('univint'));
add_unixutil(ADirectory+IncludeTrailingPathDelimiter('unixutil'));
add_unzip(ADirectory+IncludeTrailingPathDelimiter('unzip'));

6
packages/fpmake_proc.inc
View File

@ -679,6 +679,12 @@ begin
{$include tosunits/fpmake.pp}
end;
procedure add_tplylib(const ADirectory: string);
begin
with Installer do
{$include tplylib/fpmake.pp}
end;
procedure add_univint(const ADirectory: string);
begin
with Installer do

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

@ -210,10 +210,9 @@ begin
if (UnitNameLen>0) and Assigned(OnUnitAlias) then
begin
UnitNameMaxLen:=Max(UnitNameLen,255);
s:=UseUnitName;
SetLength(s,UnitNameMaxLen);
s:=UseUnitName+StringOfChar(#0,UnitNameMaxLen-UnitNameLen);
if OnUnitAlias(OnUnitAliasData,Pointer(s),UnitNameMaxLen) then
UseUnitName:=LeftStr(s,UnitNameLen);
UseUnitName:=PAnsiChar(s);
end;
end;

2745
packages/tplylib/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

102
packages/tplylib/Makefile.fpc Normal file
View File

@ -0,0 +1,102 @@
#
# Makefile.fpc for running fpmake
#
[package]
name=tplylib
version=3.3.1
[require]
packages=rtl fpmkunit
[install]
fpcpackage=y
[default]
fpcdir=../..
[prerules]
FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
ifdef OS_TARGET
FPC_TARGETOPT+=--os=$(OS_TARGET)
endif
ifdef CPU_TARGET
FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
endif
LOCALFPMAKE=./fpmake$(SRCEXEEXT)
[rules]
# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
# Compose general fpmake-parameters
ifdef FPMAKEOPT
FPMAKE_OPT+=$(FPMAKEOPT)
endif
FPMAKE_OPT+=--localunitdir=../..
FPMAKE_OPT+=--globalunitdir=..
FPMAKE_OPT+=$(FPC_TARGETOPT)
FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
FPMAKE_OPT+=--compiler=$(FPC)
FPMAKE_OPT+=-bu
.NOTPARALLEL:
fpmake$(SRCEXEEXT): fpmake.pp
$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
all: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT)
smart: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
release: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
debug: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
# most often fail because the dependencies are cleared.
# In case of a clean, simply do nothing
ifeq ($(FPMAKE_BIN_CLEAN),)
clean:
else
clean:
$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
endif
# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
# when the package is compiled using fpcmake prior to running this clean using fpmake
ifeq ($(FPMAKE_BIN_CLEAN),)
distclean: $(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
else
distclean:
ifdef inUnix
{ $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi; }
else
$(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
endif
-$(DEL) $(LOCALFPMAKE)
endif
cleanall: distclean
install: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
endif
# distinstall also installs the example-sources and omits the location of the source-
# files from the fpunits.cfg files.
distinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
endif
zipinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
zipdistinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
zipsourceinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
else
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
endif

54
packages/tplylib/fpmake.pp Normal file
View File

@ -0,0 +1,54 @@
{$ifndef ALLPACKAGES}
{$mode objfpc}{$H+}
program fpmake;
uses fpmkunit;
Var
T : TTarget;
P : TPackage;
begin
With Installer do
begin
{$endif ALLPACKAGES}
P:=AddPackage('tplylib');
P.ShortName:='tplylib';
{$ifdef ALLPACKAGES}
P.Directory:=ADirectory;
{$endif ALLPACKAGES}
P.Version:='3.3.1';
{ java and jvm-android do not support
fpc_get_output used in these sources }
if Defaults.CPU=jvm then
P.OSes := P.OSes - [java,android];
{ palmos does not support command line parameters }
P.OSes := P.OSes - [palmos];
{ Program does not fit in 16-bit memory constraints }
P.OSes := P.OSes - [msdos,win16];
{ avr-embedded and i8086-embedded do not meet needed requirements }
if Defaults.CPU in [avr,i8086] then
P.OSes := P.OSes - [embedded];
P.Author := '<various>';
P.License := 'LGPL with modification';
P.HomepageURL := 'www.freepascal.org';
P.Email := '';
P.Description := 'Library units for a compiler generator for Turbo Pascal and compatibles.';
P.NeedLibC:= false;
P.SourcePath.Add('src');
P.IncludePath.Add('src');
P.Options.Add('-Sg');
P.Targets.AddUnit('lexlib.pas');
P.Targets.AddUnit('yacclib.pas');
{$ifndef ALLPACKAGES}
Run;
end;
end.
{$endif ALLPACKAGES}

25
utils/tply/lexlib.pas → packages/tplylib/src/lexlib.pas
View File

@ -70,15 +70,15 @@ yyleng : Byte (* length of matched text *)
put_char by another suitable set of routines, e.g. if you want to read
from/write to memory, etc. *)
function get_char : Char;
var get_char: function : Char;
(* obtain one character from the input file (null character at end-of-
file) *)
procedure unget_char ( c : Char );
var unget_char : procedure ( c : Char );
(* return one character to the input file to be reread in subsequent calls
to get_char *)
procedure put_char ( c : Char );
var put_char: procedure ( c : Char );
(* write one character to the output file *)
(* Utility routines: *)
@ -185,7 +185,7 @@ var
bufptr : Integer;
buf : array [1..max_chars] of Char;
function get_char : Char;
function lexlib_get_char : Char;
var i : Integer;
begin
if (bufptr=0) and not eof(yyinput) then
@ -199,15 +199,15 @@ function get_char : Char;
end;
if bufptr>0 then
begin
get_char := buf[bufptr];
lexlib_get_char := buf[bufptr];
dec(bufptr);
inc(yycolno);
end
else
get_char := #0;
lexlib_get_char := #0;
end(*get_char*);
procedure unget_char ( c : Char );
procedure lexlib_unget_char ( c : Char );
begin
if bufptr=max_chars then fatal('input buffer overflow');
inc(bufptr);
@ -215,7 +215,7 @@ procedure unget_char ( c : Char );
buf[bufptr] := c;
end(*unget_char*);
procedure put_char ( c : Char );
procedure lexlib_put_char ( c : Char );
begin
if c=#0 then
{ ignore }
@ -285,7 +285,7 @@ procedure reject;
begin
yyreject := true;
for i := yyleng+1 to yysleng do
yytext := yytext+get_char;
yytext := yytext+get_char();
dec(yymatches);
end(*reject*);
@ -334,7 +334,7 @@ procedure yynew;
procedure yyscan;
begin
if yyleng=255 then fatal('yytext overflow');
yyactchar := get_char;
yyactchar := get_char();
inc(yyleng);
yytext[yyleng] := yyactchar;
end(*yyscan*);
@ -380,7 +380,7 @@ function yyfind ( var n : Integer ) : Boolean;
function yydefault : Boolean;
begin
yyreject := false;
yyactchar := get_char;
yyactchar := get_char();
if yyactchar<>#0 then
begin
put_char(yyactchar);
@ -406,6 +406,9 @@ procedure yyclear;
begin
yywrap := @lexlib_yywrap;
get_char:= @lexlib_get_char;
unget_char:= @lexlib_unget_char;
put_char:= @lexlib_put_char;
assign(yyinput, '');
assign(yyoutput, '');
reset(yyinput); rewrite(yyoutput);

0
utils/tply/yacclib.pas → packages/tplylib/src/yacclib.pas
View File

173
tests/webtbs/tw37554.pp Normal file
View File

@ -0,0 +1,173 @@
program tw37554;
{$mode objfpc}{$H+}
const
CmpArray: array[0..88] of Int64 = (
-1, $FFFFFFFF, -3000000, -2147483648, -131073,
$FFFFFFFFFFFF0000, $FFFFFFFF0000FFFF, $FFFF0000FFFFFFFF, $0000FFFFFFFFFFFF,
$FFFFFFFFFFFFFFFE, $FFFFFFFFFFFFFFFD, $FFFFFFFFFFFFFFFB, $FFFFFFFFFFFFFFF7,
$FFFFFFFFFFFFFFEF, $FFFFFFFFFFFFFFDF, $FFFFFFFFFFFFFFBF, $FFFFFFFFFFFFFF7F,
$FFFFFFFFFFFFFEFF, $FFFFFFFFFFFFFDFF, $FFFFFFFFFFFFFBFF, $FFFFFFFFFFFFF7FF,
$FFFFFFFFFFFFEFFF, $FFFFFFFFFFFFDFFF, $FFFFFFFFFFFFBFFF, $FFFFFFFFFFFF7FFF,
$FFFFFFFFFFFEFFFF, $FFFFFFFFFFFDFFFF, $FFFFFFFFFFFBFFFF, $FFFFFFFFFFF7FFFF,
$FFFFFFFFFFEFFFFF, $FFFFFFFFFFDFFFFF, $FFFFFFFFFFBFFFFF, $FFFFFFFFFF7FFFFF,
$FFFFFFFFFEFFFFFF, $FFFFFFFFFDFFFFFF, $FFFFFFFFFBFFFFFF, $FFFFFFFFF7FFFFFF,
$FFFFFFFFEFFFFFFF, $FFFFFFFFDFFFFFFF, $FFFFFFFFBFFFFFFF, $FFFFFFFF7FFFFFFF,
$FFFFFFFEFFFFFFFF, $FFFFFFFDFFFFFFFF, $FFFFFFFBFFFFFFFF, $FFFFFFF7FFFFFFFF,
$FFFFFFEFFFFFFFFF, $FFFFFFDFFFFFFFFF, $FFFFFFBFFFFFFFFF, $FFFFFF7FFFFFFFFF,
$FFFFFEFFFFFFFFFF, $FFFFFDFFFFFFFFFF, $FFFFFBFFFFFFFFFF, $FFFFF7FFFFFFFFFF,
$FFFFEFFFFFFFFFFF, $FFFFDFFFFFFFFFFF, $FFFFBFFFFFFFFFFF, $FFFF7FFFFFFFFFFF,
$FFFEFFFFFFFFFFFF, $FFFDFFFFFFFFFFFF, $FFFBFFFFFFFFFFFF, $FFF7FFFFFFFFFFFF,
$FFEFFFFFFFFFFFFF, $FFDFFFFFFFFFFFFF, $FFBFFFFFFFFFFFFF, $FF7FFFFFFFFFFFFF,
$FEFFFFFFFFFFFFFF, $FDFFFFFFFFFFFFFF, $FBFFFFFFFFFFFFFF, $F7FFFFFFFFFFFFFF,
$EFFFFFFFFFFFFFFF, $DFFFFFFFFFFFFFFF, $BFFFFFFFFFFFFFFF, $7FFFFFFFFFFFFFFF,
$FFFFFFFFFFFF1234, $FFFFFFFF1234FFFF, $FFFF1234FFFFFFFF, $1234FFFFFFFFFFFF,
$FFFFFFFF12341234, $FFFF1234FFFF1234, $FFFF12341234FFFF, $FFFF123412341234,
$FFFFFFFFFFFF0001, $FFFFFFFF0001FFFF, $FFFF0001FFFFFFFF, $0001FFFFFFFFFFFF,
$0000000100000001, $0000000500000005, $0000AAAA0000AAAA, $0000FFFF0000FFFF
);
var
Fail: Boolean;
procedure CompareImmediate(CmpIndex: Integer; TestVal: Int64);
begin
Write('Test ', CmpIndex, '; input constant: ', TestVal, '; comparing against: ', CmpArray[CmpIndex], ' - ');
if TestVal = CmpArray[CmpIndex] then
begin
WriteLn('Pass');
Exit;
end;
WriteLn('FAIL - expected ', CmpArray[CmpIndex]);
Fail := True;
end;
begin
Fail := False;
CompareImmediate(0, -1);
CompareImmediate(1, $FFFFFFFF);
CompareImmediate(2, -3000000);
CompareImmediate(3, -2147483648);
CompareImmediate(4, -131073);
CompareImmediate(5, $FFFFFFFFFFFF0000);
CompareImmediate(6, $FFFFFFFF0000FFFF);
CompareImmediate(7, $FFFF0000FFFFFFFF);
CompareImmediate(8, $0000FFFFFFFFFFFF);
CompareImmediate(9, $FFFFFFFFFFFFFFFE);
CompareImmediate(10, $FFFFFFFFFFFFFFFD);
CompareImmediate(11, $FFFFFFFFFFFFFFFB);
CompareImmediate(12, $FFFFFFFFFFFFFFF7);
CompareImmediate(13, $FFFFFFFFFFFFFFEF);
CompareImmediate(14, $FFFFFFFFFFFFFFDF);
CompareImmediate(15, $FFFFFFFFFFFFFFBF);
CompareImmediate(16, $FFFFFFFFFFFFFF7F);
CompareImmediate(17, $FFFFFFFFFFFFFEFF);
CompareImmediate(18, $FFFFFFFFFFFFFDFF);
CompareImmediate(19, $FFFFFFFFFFFFFBFF);
CompareImmediate(20, $FFFFFFFFFFFFF7FF);
CompareImmediate(21, $FFFFFFFFFFFFEFFF);
CompareImmediate(22, $FFFFFFFFFFFFDFFF);
CompareImmediate(23, $FFFFFFFFFFFFBFFF);
CompareImmediate(24, $FFFFFFFFFFFF7FFF);
CompareImmediate(25, $FFFFFFFFFFFEFFFF);
CompareImmediate(26, $FFFFFFFFFFFDFFFF);
CompareImmediate(27, $FFFFFFFFFFFBFFFF);
CompareImmediate(28, $FFFFFFFFFFF7FFFF);
CompareImmediate(29, $FFFFFFFFFFEFFFFF);
CompareImmediate(30, $FFFFFFFFFFDFFFFF);
CompareImmediate(31, $FFFFFFFFFFBFFFFF);
CompareImmediate(32, $FFFFFFFFFF7FFFFF);
CompareImmediate(33, $FFFFFFFFFEFFFFFF);
CompareImmediate(34, $FFFFFFFFFDFFFFFF);
CompareImmediate(35, $FFFFFFFFFBFFFFFF);
CompareImmediate(36, $FFFFFFFFF7FFFFFF);
CompareImmediate(37, $FFFFFFFFEFFFFFFF);
CompareImmediate(38, $FFFFFFFFDFFFFFFF);
CompareImmediate(39, $FFFFFFFFBFFFFFFF);
CompareImmediate(40, $FFFFFFFF7FFFFFFF);
CompareImmediate(41, $FFFFFFFEFFFFFFFF);
CompareImmediate(42, $FFFFFFFDFFFFFFFF);
CompareImmediate(43, $FFFFFFFBFFFFFFFF);
CompareImmediate(44, $FFFFFFF7FFFFFFFF);
CompareImmediate(45, $FFFFFFEFFFFFFFFF);
CompareImmediate(46, $FFFFFFDFFFFFFFFF);
CompareImmediate(47, $FFFFFFBFFFFFFFFF);
CompareImmediate(48, $FFFFFF7FFFFFFFFF);
CompareImmediate(49, $FFFFFEFFFFFFFFFF);
CompareImmediate(50, $FFFFFDFFFFFFFFFF);
CompareImmediate(51, $FFFFFBFFFFFFFFFF);
CompareImmediate(52, $FFFFF7FFFFFFFFFF);
CompareImmediate(53, $FFFFEFFFFFFFFFFF);
CompareImmediate(54, $FFFFDFFFFFFFFFFF);
CompareImmediate(55, $FFFFBFFFFFFFFFFF);
CompareImmediate(56, $FFFF7FFFFFFFFFFF);
CompareImmediate(57, $FFFEFFFFFFFFFFFF);
CompareImmediate(58, $FFFDFFFFFFFFFFFF);
CompareImmediate(59, $FFFBFFFFFFFFFFFF);
CompareImmediate(60, $FFF7FFFFFFFFFFFF);
CompareImmediate(61, $FFEFFFFFFFFFFFFF);
CompareImmediate(62, $FFDFFFFFFFFFFFFF);
CompareImmediate(63, $FFBFFFFFFFFFFFFF);
CompareImmediate(64, $FF7FFFFFFFFFFFFF);
CompareImmediate(65, $FEFFFFFFFFFFFFFF);
CompareImmediate(66, $FDFFFFFFFFFFFFFF);
CompareImmediate(67, $FBFFFFFFFFFFFFFF);
CompareImmediate(68, $F7FFFFFFFFFFFFFF);
CompareImmediate(69, $EFFFFFFFFFFFFFFF);
CompareImmediate(70, $DFFFFFFFFFFFFFFF);
CompareImmediate(71, $BFFFFFFFFFFFFFFF);
CompareImmediate(72, $7FFFFFFFFFFFFFFF);
CompareImmediate(73, $FFFFFFFFFFFF1234);
CompareImmediate(74, $FFFFFFFF1234FFFF);
CompareImmediate(75, $FFFF1234FFFFFFFF);
CompareImmediate(76, $1234FFFFFFFFFFFF);
CompareImmediate(77, $FFFFFFFF12341234);
CompareImmediate(78, $FFFF1234FFFF1234);
CompareImmediate(79, $FFFF12341234FFFF);
CompareImmediate(80, $FFFF123412341234);
CompareImmediate(81, $FFFFFFFFFFFF0001);
CompareImmediate(82, $FFFFFFFF0001FFFF);
CompareImmediate(83, $FFFF0001FFFFFFFF);
CompareImmediate(84, $0001FFFFFFFFFFFF);
CompareImmediate(85, $0000000100000001);
CompareImmediate(86, $0000000500000005);
CompareImmediate(87, $0000AAAA0000AAAA);
CompareImmediate(88, $0000FFFF0000FFFF);
{ Spacing }
WriteLn('');
if Fail then
Halt(1)
else
WriteLn('ok');
end.

12
utils/fpcres/fpcres.pas
View File

@ -23,12 +23,11 @@ uses
closablefilestream, resource,
//readers
resreader, coffreader, winpeimagereader, elfreader, machoreader,
externalreader, dfmreader, tlbreader,
externalreader, dfmreader, tlbreader, rcreader,
//writers
reswriter, coffwriter, xcoffwriter, elfwriter, machowriter, externalwriter,
//misc
elfconsts, cofftypes, machotypes, externaltypes
;
elfconsts, cofftypes, machotypes, externaltypes;
const
halt_no_err = 0;
@ -66,6 +65,10 @@ begin
writeln(' --version, -V Show program version.');
writeln(' --verbose, -v Be verbose.');
writeln(' --input, -i <x> Ignored for compatibility.');
writeln(' --include, -I <x> RC files: add a path for include searches');
writeln(' --define, -D <sym>[=<val>]');
writeln(' RC files: define a symbol (and value)');
writeln(' --undefine, -U <sym> RC files: undefine a symbol');
writeln(' --output, -o <x> Set the output file name.');
writeln(' -of <format> Set the output file format. Supported formats:');
writeln(' res, elf, coff, mach-o, external');
@ -213,6 +216,9 @@ begin
resources:=TResources.Create;
sourcefiles:=TSourceFiles.Create;
sourcefiles.FileList.AddStrings(params.InputFiles);
sourcefiles.RCDefines.AddStrings(params.RCDefines);
sourcefiles.RCIncludeDirs.AddStrings(params.RCIncludeDirs);
sourcefiles.RCMode:=CurrentTarget.objformat=ofRes;
try
sourcefiles.Load(resources);
except

54
utils/fpcres/paramparser.pas
View File

@ -45,8 +45,12 @@ type
fInputFiles : TStringList;
fOutputFile : string;
fTarget : TResTarget;
fRCIncludeDirs: TStringList;
fRCDefines: TStringList;
procedure ParseInputFiles(aList : TStringList; var index : integer; const parname : string);
procedure ParseRCInclude(aList: TStringList; var index: integer; const parname: string);
procedure ParseRCUnDefine(aList: TStringList; var index: integer; const parname: string);
procedure ParseOutputFile(aList : TStringList; var index : integer; const parname : string);
procedure ParseOutputFormat(aList : TStringList; var index : integer; const parname : string);virtual;
procedure ParseArchitecture(aList : TStringList; var index : integer; const parname : string);virtual;
@ -65,6 +69,8 @@ type
property Version : boolean read fVersion;
property Verbose : boolean read fVerbose;
property InputFiles : TStringList read fInputFiles;
property RCIncludeDirs: TStringList read fRCIncludeDirs;
property RCDefines: TStringList read fRCDefines;
property OutputFile : string read fOutputFile write fOutputFile;
property Target : TResTarget read fTarget;
end;
@ -195,6 +201,42 @@ begin
end;
end;
procedure TParameters.ParseRCInclude(aList: TStringList; var index: integer;
const parname : string);
var
tmp: String;
begin
inc(index);
tmp:=DoMandatoryArgument(aList,index);
if tmp='' then
raise EArgumentMissingException.Create(parname);
fRCIncludeDirs.Add(tmp);
end;
procedure TParameters.ParseRCUnDefine(aList: TStringList; var index: integer;
const parname : string);
var
tmp: String;
i: integer;
begin
inc(index);
tmp:=DoMandatoryArgument(aList,index);
if tmp='' then
raise EArgumentMissingException.Create(parname);
if (parname='-D') or (parname='--define') then begin
i:= pos('=', tmp);
if i<1 then
fRCDefines.Values[tmp]:= ''
else
fRCDefines.Values[Copy(tmp, 1, i-1)]:= Copy(tmp, i+1);
end else begin
i:= fRCDefines.IndexOfName(tmp);
if i >= 0 then
fRCDefines.Delete(i);
end;
fRCIncludeDirs.Add(tmp);
end;
procedure TParameters.ParseOutputFile(aList: TStringList; var index: integer;
const parname : string);
begin
@ -361,6 +403,11 @@ begin
fVerbose:=true
else if ((tmp='-i') or (tmp='--input')) then
ParseInputFiles(fList,i,tmp)
else if ((tmp='-I') or (tmp='--include')) then
ParseRCInclude(fList,i,tmp)
else if ((tmp='-D') or (tmp='--define'))
or ((tmp='-U') or (tmp='--undefine')) then
ParseRCUnDefine(fList,i,tmp)
else if ((tmp='-o') or (tmp='--output')) then
ParseOutputFile(fList,i,tmp)
else if (tmp='-of') then
@ -386,10 +433,14 @@ end;
constructor TParameters.Create;
begin
inherited Create;
fHelp:=false;
fVersion:=false;
fVerbose:=false;
fInputFiles:=TStringList.Create;
fRCIncludeDirs:= TStringList.Create;
fRCIncludeDirs.Duplicates:= dupIgnore;
fRCDefines:= TStringList.Create;
fOutputFile:='';
fTarget.machine:=mtnone;
GetDefaultSubMachineForMachine(fTarget.machine);
@ -398,7 +449,10 @@ end;
destructor TParameters.Destroy;
begin
fRCDefines.Free;
fRCIncludeDirs.Free;
fInputFiles.Free;
inherited;
end;
end.

39
utils/fpcres/sourcehandler.pas
View File

@ -36,33 +36,46 @@ type
private
protected
fFileList : TStringList;
fRCIncludeDirs: TStringList;
fRCDefines: TStringList;
fStreamList : TFPList;
fRCMode: Boolean;
public
constructor Create;
destructor Destroy; override;
procedure Load(aResources : TResources);
property FileList : TStringList read fFileList;
property RCIncludeDirs: TStringList read fRCIncludeDirs;
property RCDefines: TStringList read fRCDefines;
property RCMode: Boolean read fRCMode write fRCMode;
end;
implementation
uses msghandler, closablefilestream;
uses msghandler, closablefilestream, rcreader;
{ TSourceFiles }
constructor TSourceFiles.Create;
begin
inherited Create;
fFileList:=TStringList.Create;
fStreamList:=TFPList.Create;
fRCDefines:= TStringList.Create;
fRCIncludeDirs:= TStringList.Create;
fRCMode:=False;
end;
destructor TSourceFiles.Destroy;
var i : integer;
begin
fRCIncludeDirs.Free;
fRCDefines.Free;
fFileList.Free;
for i:=0 to fStreamList.Count-1 do
TStream(fStreamList[i]).Free;
fStreamList.Free;
inherited;
end;
procedure TSourceFiles.Load(aResources: TResources);
@ -70,7 +83,9 @@ var aReader : TAbstractResourceReader;
aStream : TClosableFileStream;
i : integer;
tmpres : TResources;
olddir : String;
begin
olddir:=GetCurrentDir;
tmpres:=TResources.Create;
try
for i:=0 to fFileList.Count-1 do
@ -82,18 +97,30 @@ begin
raise ECantOpenFileException.Create(fFileList[i]);
end;
fStreamList.Add(aStream);
try
aReader:=TResources.FindReader(aStream);
except
raise EUnknownInputFormatException.Create(fFileList[i]);
end;
{ the RC reader reads anything, so handle that separately }
if fRCMode then
aReader:=TRCResourceReader.Create
else
try
aReader:=TResources.FindReader(aStream);
except
raise EUnknownInputFormatException.Create(fFileList[i]);
end;
Messages.DoVerbose(Format('Chosen reader: %s',[aReader.Description]));
try
Messages.DoVerbose('Reading resource information...');
if aReader is TRCResourceReader then begin
TRCResourceReader(aReader).RCIncludeDirs.Assign(fRCIncludeDirs);
TRCResourceReader(aReader).RCDefines.Assign(fRCDefines);
SetCurrentDir(ExtractFilePath(ExpandFileName(fFileList[i])));
end;
tmpres.LoadFromStream(aStream,aReader);
aResources.MoveFrom(tmpres);
Messages.DoVerbose('Resource information read');
finally
if aReader is TRCResourceReader then begin
SetCurrentDir(olddir);
end;
aReader.Free;
end;
end;

6
utils/tply/fpmake.pp
View File

@ -39,6 +39,8 @@ begin
P.Directory:=ADirectory;
P.Version:='3.3.1';
P.Dependencies.Add('tplylib');
P.Options.Add('-Sg');
T:=P.Targets.AddProgram('plex.pas');
@ -62,10 +64,6 @@ begin
T.Dependencies.AddUnit('yacclr0');
T.Dependencies.AddUnit('yacctabl');
P.Targets.AddUnit('lexlib.pas');
P.Targets.AddUnit('yacclib.pas');
P.Targets.AddUnit('lexbase.pas').install:=false;
P.Targets.AddUnit('lexopt.pas').install:=false;
P.Targets.AddUnit('lexdfa.pas').install:=false;

3
utils/tply/lexdfa.pas
View File

@ -53,7 +53,8 @@ procedure makeDFATable;
begin
(* initialize start states: *)
for i := 2 to 2*n_start_states+1 do
setunion(first_pos_table^[i]^, first_pos_table^[i mod 2]^);
if not start_excl^[i div 2] then
setunion(first_pos_table^[i]^, first_pos_table^[i mod 2]^);
for i := 0 to 2*n_start_states+1 do
act_state := newState(first_pos_table^[i]);
act_state := -1;

4
utils/tply/lextable.pas
View File

@ -105,6 +105,8 @@ FirstPosTable = array [0..2*max_start_states+1] of IntSetPtr;
default, states 2..2*n_start_states+1 user-defined
start states) *)
StartStateExclusive = array[0..max_start_states] of Boolean;
StateTableEntry = record
state_pos : IntSetPtr;
(* positions covered by state *)
@ -137,6 +139,7 @@ optimize : Boolean; (* status of the optimization option *)
sym_table : ^SymTable; (* symbol table *)
pos_table : ^PosTable; (* position table *)
first_pos_table : ^FirstPosTable; (* first positions table *)
start_excl : ^StartStateExclusive; (* user-defined start state type *)
state_table : ^StateTable; (* DFA state table *)
trans_table : ^TransTable; (* DFA transition table *)
@ -460,6 +463,7 @@ begin
new(sym_table);
new(pos_table);
new(first_pos_table);
new(start_excl);
new(state_table);
new(trans_table);

7
utils/tply/plex.pas
View File

@ -88,7 +88,7 @@ procedure next_section;
var n_rules : Integer; (* current number of rules *)
procedure define_start_state ( symbol : String; pos : Integer );
procedure define_start_state ( symbol : String; pos : Integer; excl : Boolean );
(* process start state definition *)
begin
{$ifdef fpc}
@ -106,6 +106,7 @@ procedure define_start_state ( symbol : String; pos : Integer );
writeln(yyout, 'const ', symbol, ' = ', 2*start_state, ';');
first_pos_table^[2*start_state] := newIntSet;
first_pos_table^[2*start_state+1] := newIntSet;
start_excl^[start_state] := excl;
end
else
error(symbol_already_defined, pos)
@ -505,12 +506,12 @@ procedure definitions;
begin
split(line, 2);
com := upper(itemv(1));
if (com='%S') or (com='%START') then
if (com='%S') or (com='%START') or (com='%X') then
begin
split(line, max_items);
for i := 2 to itemc do
if check_id(itemv(i)) then
define_start_state(itemv(i), itempos[i])
define_start_state(itemv(i), itempos[i], com='%X')
else
error(syntax_error, itempos[i]);
end