paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-10 06:04:32 +01:00
Code Issues Packages Projects Releases Wiki Activity

* smartlinking for sets

Browse Source 
+ consts labels are now concated/generated in hcodegen
  * moved some cpu code to cga and some none cpu depended code from cga
    to tree and hcodegen and cleanup of hcodegen
  * assembling .. output reduced for smartlinking ;)
This commit is contained in:
peter 1998-05-07 00:16:59 +00:00
parent 2c92c249f2
commit 7e06238905
6 changed files with 340 additions and 912 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
compiler/aasm.pas
View File

@ -73,10 +73,9 @@ unit aasm;
type
{ the short name makes typing easier }
pai = ^tai;
tai = object(tlinkedlist_item)
typ : tait;
line : longint;
typ : tait;
line : longint;
infile : pinputfile;
constructor init;
end;
@ -93,9 +92,8 @@ unit aasm;
destructor done;virtual;
end;
pai_symbol = ^tai_symbol;
{ generates a common label }
pai_symbol = ^tai_symbol;
tai_symbol = object(tai)
name : pchar;
is_global : boolean;
@ -107,12 +105,11 @@ unit aasm;
{ external types defined for TASM }
{ EXT_ANY for search purposes }
texternal_typ = (EXT_ANY,EXT_NEAR, EXT_FAR, EXT_PROC, EXT_BYTE,
EXT_WORD, EXT_DWORD, EXT_CODEPTR, EXT_DATAPTR,
EXT_FWORD, EXT_PWORD, EXT_QWORD, EXT_TBYTE, EXT_ABS);
pai_external = ^tai_external;
EXT_WORD, EXT_DWORD, EXT_CODEPTR, EXT_DATAPTR,
EXT_FWORD, EXT_PWORD, EXT_QWORD, EXT_TBYTE, EXT_ABS);
{ generates an symbol which is marked as external }
pai_external = ^tai_external;
tai_external = object(tai)
name : pchar;
exttyp : texternal_typ;
@ -120,11 +117,9 @@ unit aasm;
destructor done; virtual;
end;
{ simple temporary label }
pai_label = ^tai_label;
{ type for a temporary label }
{ test if used for dispose of unnecessary labels }
pai_label = ^tai_label;
tlabel = record
nb : longint;
is_used : boolean;
@ -133,7 +128,6 @@ unit aasm;
end;
plabel = ^tlabel;
tai_label = object(tai)
l : plabel;
constructor init(_l : plabel);
@ -147,8 +141,8 @@ unit aasm;
destructor done; virtual;
end;
{ to insert a comment into the generated assembler file }
{ to insert a comment into the generated assembler file }
pai_asm_comment = ^tai_asm_comment;
tai_asm_comment = object(tai)
str : pchar;
@ -156,9 +150,8 @@ unit aasm;
destructor done; virtual;
end;
{ alignment for operator }
pai_align = ^tai_align;
tai_align = object(tai)
aligntype: byte; { 1 = no align, 2 = word align, 4 = dword align }
@ -168,11 +161,10 @@ unit aasm;
destructor done;virtual;
end;
{ Insert a section/segment directive }
tsection=(sec_none,sec_code,sec_data,sec_bss,sec_idata);
{ Insert a section/segment directive }
pai_section = ^tai_section;
tai_section = object(tai)
sec : tsection;
@ -182,9 +174,9 @@ unit aasm;
destructor done;virtual;
end;
pai_datablock = ^tai_datablock;
{ generates an uninitilizised data block }
{ generates an uninitializised data block }
pai_datablock = ^tai_datablock;
tai_datablock = object(tai)
size : longint;
name : pchar;
@ -194,9 +186,9 @@ unit aasm;
destructor done; virtual;
end;
pai_const = ^tai_const;
{ generates a long integer (32 bit) }
pai_const = ^tai_const;
tai_const = object(tai)
value : longint;
constructor init_32bit(_value : longint);
@ -207,17 +199,17 @@ unit aasm;
destructor done;virtual;
end;
pai_double = ^tai_double;
{ generates a double (64 bit real) }
pai_double = ^tai_double;
tai_double = object(tai)
value : double;
constructor init(_value : double);
end;
pai_comp = ^tai_comp;
{ generates an comp (integer over 64 bits) }
pai_comp = ^tai_comp;
tai_comp = object(tai)
value : bestreal;
constructor init(_value : bestreal);
@ -225,24 +217,24 @@ unit aasm;
constructor init_comp(_value : comp);
end;
pai_single = ^tai_single;
{ generates a single (32 bit real) }
pai_single = ^tai_single;
tai_single = object(tai)
value : single;
constructor init(_value : single);
end;
pai_extended = ^tai_extended;
{ generates an extended (80 bit real) }
{ for version above v0_9_8 }
{ creates a double otherwise }
pai_extended = ^tai_extended;
tai_extended = object(tai)
value : bestreal;
constructor init(_value : bestreal);
end;
{ insert a cut to split into several smaller files }
pai_cut = ^tai_cut;
tai_cut = object(tai)
constructor init;
@ -251,19 +243,11 @@ unit aasm;
{ for each processor define the best precision }
{ bestreal is defined in globals }
{$ifdef i386}
{$ifdef ver_above0_9_8}
const
ait_bestreal = ait_real_extended;
type
pai_bestreal = pai_extended;
tai_bestreal = tai_extended;
{$else ver_above0_9_8}
const
ait_bestreal = ait_real_64bit;
type
pai_bestreal = pai_double;
tai_bestreal = tai_double;
{$endif ver_above0_9_8}
{$endif i386}
{$ifdef m68k}
const
@ -273,29 +257,31 @@ type
tai_bestreal = tai_single;
{$endif m68k}
paasmoutput = ^taasmoutput;
taasmoutput = tlinkedlist;
var
datasegment,codesegment,bsssegment,
internals,externals,debuglist,consts,importssection,
exportssection,resourcesection,rttilist : paasmoutput;
internals,externals,debuglist,consts,
importssection,exportssection,
resourcesection,rttilist : paasmoutput;
{ external symbols without repetition }
{ external symbols without repetition }
function search_assembler_symbol(pl : paasmoutput;const _name : string;exttype : texternal_typ) : pai_external;
procedure concat_external(const _name : string;exttype : texternal_typ);
procedure concat_internal(const _name : string;exttype : texternal_typ);
implementation
uses strings,verbose;
uses
strings,verbose;
{****************************************************************************
TAI
****************************************************************************}
constructor tai.init;
begin
{$ifdef GDB}
infile:=pointer(current_module^.current_inputfile);
@ -303,6 +289,7 @@ type
line:=current_module^.current_inputfile^.line_no;
{$endif GDB}
end;
{****************************************************************************
TAI_SECTION
****************************************************************************}
@ -737,7 +724,14 @@ type
end.
{
$Log$
Revision 1.6 1998-05-06 18:36:53 peter
Revision 1.7 1998-05-07 00:16:59 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.6 1998/05/06 18:36:53 peter
* tai_section extended with code,data,bss sections and enumerated type
* ident 'compiled by FPC' moved to pmodules
* small fix for smartlink

16
compiler/assemble.pas
View File

@ -175,8 +175,8 @@ begin
DoAssemble:=true;
if DoPipe then
exit;
if not externasm then
Message1(exec_i_assembling,asmfile);
if (smartcnt<=1) and (not externasm) then
Message1(exec_i_assembling,name);
s:=target_asm.asmcmd;
Replace(s,'$ASM',AsmFile);
Replace(s,'$OBJ',ObjFile);
@ -400,7 +400,14 @@ end;
end.
{
$Log$
Revision 1.6 1998-05-04 17:54:24 peter
Revision 1.7 1998-05-07 00:17:00 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.6 1998/05/04 17:54:24 peter
+ smartlinking works (only case jumptable left todo)
* redesign of systems.pas to support assemblers and linkers
+ Unitname is now also in the PPU-file, increased version to 14
@ -425,7 +432,4 @@ end.
Revision 1.2 1998/04/08 11:34:18 peter
* nasm works (linux only tested)
Revision 1.1.1.1 1998/03/25 11:18:16 root
* Restored version
}

197
compiler/cga68k.pas
View File

@ -25,8 +25,7 @@ unit cga68k;
interface
uses
objects,cobjects,verbose,systems,globals,tree,symtable,types,strings,
pass_1,hcodegen,aasm,m68k,tgen68k,files,gdb;
cobjects,tree,m68k,aasm,symtable;
procedure emitl(op : tasmop;var l : plabel);
procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
@ -41,7 +40,6 @@ unit cga68k;
procedure restore(p : ptree);
procedure emit_push_mem(const ref : treference);
procedure emitpushreferenceaddr(const ref : treference);
procedure swaptree(p: ptree);
procedure copystring(const dref,sref : treference;len : byte);
procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
{ see implementation }
@ -60,13 +58,9 @@ unit cga68k;
procedure firstcomplex(p : ptree);
procedure secondfuncret(var p : ptree);
{ initialize respectively terminates the code generator }
{ for a new module or procedure }
procedure codegen_doneprocedure;
procedure codegen_donemodule;
procedure codegen_newmodule;
procedure codegen_newprocedure;
{ generate stackframe for interrupt procedures }
procedure generate_interrupt_stackframe_entry;
procedure generate_interrupt_stackframe_exit;
{ generate entry code for a procedure.}
procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
stackframe:longint;
@ -77,6 +71,16 @@ unit cga68k;
implementation
uses
systems,globals,verbose,files,types,pbase,
tgenm68k,hcodegen
{$ifdef GDB}
,gdb
{$endif}
;
{
procedure genconstadd(size : topsize;l : longint;const str : string);
@ -426,17 +430,18 @@ unit cga68k;
end;
end;
procedure swaptree(p:Ptree);
procedure generate_interrupt_stackframe_entry;
begin
{ save the registers of an interrupt procedure }
var swapp:Ptree;
{ .... also the segment registers }
end;
begin
swapp:=p^.right;
p^.right:=p^.left;
p^.left:=swapp;
p^.swaped:=not(p^.swaped);
end;
procedure generate_interrupt_stackframe_exit;
begin
{ restore the registers of an interrupt procedure }
end;
procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
stackframe:longint;
@ -1209,161 +1214,21 @@ end;
end;
end;
procedure codegen_newprocedure;
begin
aktbreaklabel:=nil;
aktcontinuelabel:=nil;
{ aktexitlabel:=0; is store in oldaktexitlabel
so it must not be reset to zero before this storage !}
{ the type of this lists isn't important }
{ because the code of this lists is }
{ copied to the code segment }
procinfo.aktentrycode:=new(paasmoutput,init);
procinfo.aktexitcode:=new(paasmoutput,init);
procinfo.aktproccode:=new(paasmoutput,init);
end;
procedure codegen_doneprocedure;
begin
dispose(procinfo.aktentrycode,done);
dispose(procinfo.aktexitcode,done);
dispose(procinfo.aktproccode,done);
end;
procedure codegen_newmodule;
begin
exprasmlist:=new(paasmoutput,init);
end;
procedure codegen_donemodule;
begin
dispose(exprasmlist,done);
dispose(codesegment,done);
dispose(bsssegment,done);
dispose(datasegment,done);
dispose(debuglist,done);
dispose(externals,done);
dispose(consts,done);
end;
end.
{
$Log$
Revision 1.3 1998-04-29 10:33:46 pierre
Revision 1.4 1998-05-07 00:17:00 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.3 1998/04/29 10:33:46 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.2 1998/03/28 23:09:54 florian
* secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit
* loading pointer to routines hopefully fixed (m68k)
* flags problem with calls to RTL internal routines fixed (still strcmp
to fix) (m68k)
* #ELSE was still incorrect (didn't take care of the previous level)
* problem with filenames in the command line solved
* problem with mangledname solved
* linking name problem solved (was case insensitive)
* double id problem and potential crash solved
* stop after first error
* and=>test problem removed
* correct read for all float types
* 2 sigsegv fixes and a cosmetic fix for Internal Error
* push/pop is now correct optimized (=> mov (%esp),reg)
Revision 1.1.1.1 1998/03/25 11:18:13 root
* Restored version
Revision 1.15 1998/03/22 12:45:38 florian
* changes of Carl-Eric to m68k target commit:
- wrong nodes because of the new string cg in intel, I had to create
this under m68k also ... had to work it out to fix potential alignment
problems --> this removes the crash of the m68k compiler.
- added absolute addressing in m68k assembler (required for Amiga startup)
- fixed alignment problems (because of byte return values, alignment
would not be always valid) -- is this ok if i change the offset if odd in
setfirsttemp ?? -- it seems ok...
Revision 1.14 1998/03/10 04:20:37 carl
* extdebug problems
- removed loadstring as it is not required for the m68k
Revision 1.13 1998/03/10 01:17:16 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.12 1998/03/09 10:44:35 peter
+ string='', string<>'', string:='', string:=char optimizes (the first 2
were already in cg68k2)
Revision 1.11 1998/03/06 00:52:03 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.10 1998/03/03 04:12:04 carl
* moved generate routines to this unit
Revision 1.9 1998/03/02 01:48:17 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.8 1998/02/13 10:34:45 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.7 1998/02/12 11:49:50 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.6 1998/01/11 03:39:02 carl
* bugfix of concatcopy , was using wrong reference
* bugfix of MOVEQ
Revision 1.3 1997/12/09 13:30:05 carl
+ renamed some stuff
Revision 1.2 1997/12/03 13:59:01 carl
+ added emitcall as in i386 version.
Revision 1.1.1.1 1997/11/27 08:32:53 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History:
27th september 1997:
+ first version for MC68000 (using v093 template) (CEC)
9th october 1997:
* fixed a bug in push_int as well as other routines which used
getregister32 while they are not supposed to (because of how
the allocation of registers work in parser.pas) (CEC)
* Fixed some bugs in the concatcopy routine, was allocating
registers which were not supposed to be allocated. (CEC)
}

478
compiler/cgi386.pas
View File

@ -20,27 +20,14 @@
****************************************************************************
}
{$ifdef tp}
{$E+,F+,N+,D+,L-,Y+}
{$ifdef TP}
{$E+,F+,N+,D+,L-,Y+}
{$endif}
unit cgi386;
{***************************************************************************}
interface
{***************************************************************************}
uses verbose,cobjects,systems,globals,tree,
symtable,types,strings,pass_1,hcodegen,
aasm,i386,tgeni386,files,cgai386
{$ifdef GDB}
,gdb
{$endif GDB}
{$ifdef TP}
,cgi3862
{$endif TP}
;
uses
tree;
{ produces assembler for the expression in variable p }
{ and produces an assembler node at the end }
@ -48,27 +35,38 @@ procedure generatecode(var p : ptree);
{ produces the actual code }
function do_secondpass(var p : ptree) : boolean;
procedure secondpass(var p : ptree);
{$ifdef test_dest_loc}
const { used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var dest_loc : tlocation;
{$ifdef test_dest_loc}
const
{ used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var
dest_loc : tlocation;
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{$endif test_dest_loc}
{***************************************************************************}
implementation
{***************************************************************************}
uses
verbose,cobjects,systems,globals,files,
symtable,types,aasm,i386,
pass_1,hcodegen,tgeni386,cgai386
{$ifdef GDB}
,gdb
{$endif}
{$ifdef TP}
,cgi3862
{$endif}
;
const
never_copy_const_param : boolean = false;
@ -610,7 +608,6 @@ implementation
hp1 : pai;
lastlabel : plabel;
found : boolean;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
@ -628,17 +625,9 @@ implementation
begin
if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
begin
{ Florian this caused a internalerror(10)=> no free reg !! }
{if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then }
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then
found:=true;
if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then
found:=true;
if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
found:=true;
if found then
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
begin
{ found! }
p^.labnumber:=lastlabel^.nb;
@ -654,35 +643,18 @@ implementation
begin
getlabel(lastlabel);
p^.labnumber:=lastlabel^.nb;
concat_constlabel(lastlabel,constreal);
case p^.realtyp of
ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued)));
ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued)));
ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued)));
else
internalerror(10120);
end;
if smartlink then
begin
consts^.insert(new(pai_symbol,init_global('_$'+current_module^.unitname^
+'$real_const'+tostr(p^.labnumber))));
consts^.insert(new(pai_cut,init));
end
else if current_module^.output_format in [of_nasm,of_obj] then
consts^.insert(new(pai_symbol,init('$real_const'+tostr(p^.labnumber))))
ait_real_64bit : consts^.concat(new(pai_double,init(p^.valued)));
ait_real_32bit : consts^.concat(new(pai_single,init(p^.valued)));
ait_real_extended : consts^.concat(new(pai_extended,init(p^.valued)));
else
consts^.insert(new(pai_label,init(lastlabel)));
internalerror(10120);
end;
end;
end;
stringdispose(p^.location.reference.symbol);
if smartlink then
begin
p^.location.reference.symbol:=stringdup('_$'+current_module^.unitname^
+'$real_const'+tostr(p^.labnumber));
end
else if current_module^.output_format in [of_nasm,of_obj] then
p^.location.reference.symbol:=stringdup('$real_const'+tostr(p^.labnumber))
else
p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,constreal));
end;
procedure secondfixconst(var p : ptree);
@ -773,44 +745,25 @@ implementation
pc:=getpcharcopy(p);
{$endif UseAnsiString}
{ we still will have a problem if there is a #0 inside the pchar }
{$ifndef UseAnsiString}
consts^.insert(new(pai_string,init_length_pchar(pc,length(p^.values^)+2)));
concat_constlabel(lastlabel,conststring);
{$ifdef UseAnsiString}
{$ifdef debug}
consts^.concat(new(pai_asm_comment,init('Header of ansistring')));
{$endif debug}
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(-1)));
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1)));
{$else UseAnsiString}
consts^.insert(new(pai_string,init_length_pchar(pc,p^.length+1)));
{$endif UseAnsiString}
if smartlink then
begin
consts^.insert(new(pai_symbol,init_global('_$'+current_module^.unitname^
+'$string_const'+tostr(p^.labstrnumber))));
consts^.insert(new(pai_cut,init));
end
else
begin
consts^.insert(new(pai_label,init(lastlabel)));
if current_module^.output_format in [of_nasm,of_obj] then
consts^.insert(new(pai_symbol,init('$string_const'+tostr(p^.labstrnumber))));
end;
{$ifdef UseAnsiString}
consts^.insert(new(pai_const,init_32bit(-1)));
consts^.insert(new(pai_const,init_32bit(p^.length)));
consts^.insert(new(pai_const,init_32bit(p^.length)));
{$ifdef debug}
consts^.insert(new(pai_asm_comment,init('Header of ansistring')));
{$endif debug}
{ we still will have a problem if there is a #0 inside the pchar }
consts^.concat(new(pai_string,init_length_pchar(pc,length(p^.values^)+2)));
{$endif UseAnsiString}
end;
end;
stringdispose(p^.location.reference.symbol);
if smartlink then
p^.location.reference.symbol:=stringdup('_$'+current_module^.unitname^
+'$string_const'+tostr(p^.labstrnumber))
else if current_module^.output_format in [of_nasm,of_obj] then
p^.location.reference.symbol:=stringdup('$string_const'+tostr(p^.labstrnumber))
else
p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,conststring));
p^.location.loc := LOC_MEM;
end;
@ -1614,9 +1567,6 @@ implementation
procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
var
pushedregs : tpushed;
begin
{$ifdef UseAnsiString}
if is_ansistring(p^.resulttype) and not is_ansistring(p^.left^.resulttype) then
@ -2207,7 +2157,6 @@ implementation
opsize : topsize;
otlabel,hlabel,oflabel : plabel;
hregister : tregister;
use_strconcat : boolean;
loc : tloc;
begin
@ -3446,7 +3395,6 @@ implementation
opsize : topsize;
asmop : tasmop;
pushed : tpushed;
dummycoll : tdefcoll;
{ produces code for READ(LN) and WRITE(LN) }
@ -3767,10 +3715,9 @@ implementation
procedure handle_str;
var
hp,node,lentree,paratree : ptree;
hp,node : ptree;
dummycoll : tdefcoll;
is_real,has_length : boolean;
real_type : byte;
begin
pushusedregisters(pushed,$ff);
@ -4339,7 +4286,7 @@ implementation
var
l : plabel;
i,smallsetvalue : longint;
i : longint;
hp : ptree;
href,sref : treference;
@ -4351,21 +4298,13 @@ implementation
clear_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
if not (current_module^.output_format in [of_nasm,of_obj]) then
begin
href.symbol:=stringdup(lab2str(l));
datasegment^.concat(new(pai_label,init(l)));
end
else
begin
href.symbol:=stringdup('$set_const'+tostr(l^.nb));
datasegment^.concat(new(pai_symbol,init('$set_const'+tostr(l^.nb))));
end;
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
{if psetdef(p^.resulttype)=smallset then
begin
smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1];
datasegment^.concat(new(pai_const,init_32bit(smallsetvalue)));
consts^.concat(new(pai_const,init_32bit(smallsetvalue)));
hp:=p^.left;
if assigned(hp) then
begin
@ -4391,7 +4330,7 @@ implementation
else }
begin
for i:=0 to 31 do
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
hp:=p^.left;
if assigned(hp) then
begin
@ -6043,7 +5982,14 @@ do_jmp:
end.
{
$Log$
Revision 1.21 1998-05-06 08:38:36 pierre
Revision 1.22 1998-05-07 00:17:00 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.21 1998/05/06 08:38:36 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
@ -6130,304 +6076,4 @@ end.
in MEM parsing for go32v2
better external symbol creation
support for rhgdb.exe (lowercase file names)
Revision 1.3 1998/03/28 23:09:55 florian
* secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit
* loading pointer to routines hopefully fixed (m68k)
* flags problem with calls to RTL internal routines fixed (still strcmp
to fix) (m68k)
* #ELSE was still incorrect (didn't take care of the previous level)
* problem with filenames in the command line solved
* problem with mangledname solved
* linking name problem solved (was case insensitive)
* double id problem and potential crash solved
* stop after first error
* and=>test problem removed
* correct read for all float types
* 2 sigsegv fixes and a cosmetic fix for Internal Error
* push/pop is now correct optimized (=> mov (%esp),reg)
Revision 1.2 1998/03/26 11:18:30 florian
- switch -Sa removed
- support of a:=b:=0 removed
Revision 1.1.1.1 1998/03/25 11:18:13 root
* Restored version
Revision 1.58 1998/03/24 21:48:30 florian
* just a couple of fixes applied:
- problem with fixed16 solved
- internalerror 10005 problem fixed
- patch for assembler reading
- small optimizer fix
- mem is now supported
Revision 1.57 1998/03/16 22:42:19 florian
* some fixes of Peter applied:
ofs problem, profiler support
Revision 1.56 1998/03/13 22:45:57 florian
* small bug fixes applied
Revision 1.55 1998/03/11 22:22:51 florian
* Fixed circular unit uses, when the units are not in the current dir (from Peter)
* -i shows correct info, not <lf> anymore (from Peter)
* linking with shared libs works again (from Peter)
Revision 1.54 1998/03/10 23:48:35 florian
* a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
enough, it doesn't run
Revision 1.53 1998/03/10 16:27:37 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.52 1998/03/10 01:17:16 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.51 1998/03/09 10:44:37 peter
+ string='', string<>'', string:='', string:=char optimizes (the first 2
were already in cg68k2)
Revision 1.50 1998/03/06 00:52:10 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.49 1998/03/04 01:34:56 peter
* messages for unit-handling and assembler/linker
* the compiler compiles without -dGDB, but doesn't work yet
+ -vh for Hint
Revision 1.48 1998/03/03 20:36:51 florian
* bug in second_smaller fixed
Revision 1.47 1998/03/03 01:08:24 florian
* bug0105 and bug0106 problem solved
Revision 1.46 1998/03/02 01:48:24 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.45 1998/03/01 22:46:06 florian
+ some win95 linking stuff
* a couple of bugs fixed:
bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
Revision 1.44 1998/02/24 16:49:57 peter
* stackframe ommiting generated 'ret $-4'
+ timer.pp bp7 version
* innr.inc are now the same files
Revision 1.43 1998/02/22 23:03:12 peter
* renamed msource->mainsource and name->unitname
* optimized filename handling, filename is not seperate anymore with
path+name+ext, this saves stackspace and a lot of fsplit()'s
* recompiling of some units in libraries fixed
* shared libraries are working again
+ $LINKLIB <lib> to support automatic linking to libraries
+ libraries are saved/read from the ppufile, also allows more libraries
per ppufile
Revision 1.42 1998/02/21 04:09:13 carl
* stupid syntax error fix
Revision 1.41 1998/02/20 20:35:14 carl
* Fixed entry and exit code which was ALL messed up
Revision 1.40 1998/02/19 12:15:08 daniel
* Optimized a statement that did pain to my eyes.
Revision 1.39 1998/02/17 21:20:40 peter
+ Script unit
+ __EXIT is called again to exit a program
- target_info.link/assembler calls
* linking works again for dos
* optimized a few filehandling functions
* fixed stabs generation for procedures
Revision 1.38 1998/02/15 21:16:12 peter
* all assembler outputs supported by assemblerobject
* cleanup with assembleroutputs, better .ascii generation
* help_constructor/destructor are now added to the externals
- generation of asmresponse is not outputformat depended
Revision 1.37 1998/02/14 01:45:15 peter
* more fixes
- pmode target is removed
- search_as_ld is removed, this is done in the link.pas/assemble.pas
+ findexe() to search for an executable (linker,assembler,binder)
Revision 1.36 1998/02/13 22:26:19 peter
* fixed a few SigSegv's
* INIT$$ was not written for linux!
* assembling and linking works again for linux and dos
+ assembler object, only attasmi3 supported yet
* restore pp.pas with AddPath etc.
Revision 1.35 1998/02/13 10:34:50 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.34 1998/02/12 17:18:57 florian
* fixed to get remake3 work, but needs additional fixes (output, I don't like
also that aktswitches isn't a pointer)
Revision 1.33 1998/02/12 11:49:56 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.23 1998/02/01 19:39:50 florian
* clean up
* bug0029 fixed
Revision 1.22 1998/01/27 22:02:29 florian
* small bug fix to the compiler work, I forgot a not(...):(
Revision 1.21 1998/01/27 10:49:15 florian
*** empty log message ***
Revision 1.20 1998/01/26 17:29:14 florian
* Peter's fix for bug0046 applied
Revision 1.19 1998/01/25 22:28:55 florian
* a lot bug fixes on the DOM
Revision 1.18 1998/01/21 21:29:50 florian
* some fixes for Delphi classes
Revision 1.17 1998/01/20 23:53:04 carl
* bugfix 74 (FINAL, the one from Pierre was incomplete under BP)
Revision 1.16 1998/01/19 10:25:14 pierre
* bug in object function call in main program or unit init fixed
Revision 1.15 1998/01/16 22:34:29 michael
* Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
in this compiler :)
Revision 1.14 1998/01/16 18:03:11 florian
* small bug fixes, some stuff of delphi styled constructores added
Revision 1.13 1998/01/13 23:11:05 florian
+ class methods
Revision 1.12 1998/01/07 00:16:44 michael
Restored released version (plus fixes) as current
Revision 1.10 1997/12/13 18:59:42 florian
+ I/O streams are now also declared as external, if neccessary
* -Aobj generates now a correct obj file via nasm
Revision 1.9 1997/12/10 23:07:16 florian
* bugs fixed: 12,38 (also m68k),39,40,41
+ warning if a system unit is without -Us compiled
+ warning if a method is virtual and private (was an error)
* some indentions changed
+ factor does a better error recovering (omit some crashes)
+ problem with @type(x) removed (crashed the compiler)
Revision 1.8 1997/12/09 13:35:47 carl
+ renamed pai_labeled386 to pai_labeled
+ renamed S_T to S_X
Revision 1.7 1997/12/04 10:39:11 pierre
+ secondadd separated in file cgi386ad.inc
Revision 1.5 1997/11/29 15:41:45 florian
only small changes
Revision 1.3 1997/11/28 15:43:15 florian
Fixed stack ajustment bug, 0.9.8 compiles now 0.9.8 without problems.
Revision 1.2 1997/11/28 14:26:19 florian
Fixed some bugs
Revision 1.1.1.1 1997/11/27 08:32:54 michael
FPC Compiler CVS start
Pre-CVS log:
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History (started with version 0.9.0):
23th october 1996:
+ some emit calls replaced (FK)
24th october 1996:
* for bug fixed (FK)
26th october 1996:
* english comments (FK)
5th november 1996:
* new init and terminate code (FK)
...... some items missed
19th september 1997:
* a call to a function procedure a;[ C ]; doesn't crash the stack
furthermore (FK)
* bug in var_reg assignment fixed
did not keep p^.register32 registers free ! (PM)
22th september 1997:
* stack layout for nested procedures in methods modified:
ESI is no more pushed (must be loaded via framepointer) (FK)
24th september 1997:
+ strings constants in consts list to check for existing strings (PM)
24th september 1997:
* constructor bug removed (FK)
* source splitted (into cgi386 and cgi3862 for FPC) (FK)
* line_no and inputfile are now in secondpass saved (FK)
* patching error removed (the switch -Ox was always used
because of a misplaced end) (FK)
+ strings constants in consts list to check for existing strings (PM)
25th september 1997:
+ secondload provides now the informations for open arrays (FK)
+ support of high for open arrays (FK)
+ the high parameter is now pushed for open arrays (FK)
3th october 1997:
+ function second_bool_to_byte for ord(boolean) (PM)
4th october 1997:
+ code for in_pred_x in_succ_x no bound check (PM)
13th october 1997:
+ added code for static modifier for objects variables and methods (PM)
14th october 1997:
+ second_bool_to_byte handles now also LOC_JUMP (FK)
28th october 1997:
* in secondcallparan bug with param from read/write while nil defcoll^.data
fixed (PM)
3rd november 1997:
+ added code for symdif for sets (PM)
28th october 1997:
* in secondcallparan bug with param from read/write while nil defcoll^.data
fixed (PM)
3rd november 1997:
+ added code for symdif for sets (PM)
12th november 1997:
+ added text write for boolean (PM)
* bug in secondcallparan for LOC_FPU (assumed that the type was double) (PM)
13th november 1997:
+ added partial code for u32bit support (PM)
22th november 1997:
* bug in stack alignment found (PM)
}

372
compiler/hcodegen.pas
View File

@ -24,32 +24,25 @@ unit hcodegen;
interface
uses
cobjects,systems,globals,tree,symtable,types,strings,aasm
uses
aasm,tree,symtable
{$ifdef i386}
,i386
,i386
{$endif}
{$ifdef m68k}
,m68k
,m68k
{$endif}
;
;
const
{ set, if the procedure uses asm }
pi_uses_asm = $1;
{ set, if the procedure is exported by an unit }
pi_is_global = $2;
{ set, if the procedure does a call }
{ this is for the optimizer }
pi_do_call = $4;
{ if the procedure is an operator }
pi_operator = $8;
{ set, if the procedure is an external C function }
pi_C_import = $10;
pi_uses_asm = $1; { set, if the procedure uses asm }
pi_is_global = $2; { set, if the procedure is exported by an unit }
pi_do_call = $4; { set, if the procedure does a call }
pi_operator = $8; { set, if the procedure is an operator }
pi_C_import = $10; { set, if the procedure is an external C function }
type
pprocinfo = ^tprocinfo;
tprocinfo = record
{ pointer to parent in nested procedures }
parent : pprocinfo;
@ -79,10 +72,8 @@ unit hcodegen;
{ register used as frame pointer }
framepointer : tregister;
{$ifdef GDB}
{ true, if the procedure is exported by an unit }
globalsymbol : boolean;
{$endif * GDB *}
{ true, if the procedure should be exported (only OS/2) }
exported : boolean;
@ -97,152 +88,198 @@ unit hcodegen;
{ info about the current sub routine }
procinfo : tprocinfo;
{ Die Nummer der Label die bei BREAK bzw CONTINUE }
{ angesprungen werden sollen }
{ labels for BREAK and CONTINUE }
aktbreaklabel,aktcontinuelabel : plabel;
{ truelabel wird angesprungen, wenn ein Ausdruck true ist, falselabel }
{ entsprechend }
{ label when the result is true or false }
truelabel,falselabel : plabel;
{ Nr des Labels welches zum Verlassen eines Unterprogramm }
{ angesprungen wird }
{ label to leave the sub routine }
aktexitlabel : plabel;
{ also an exit label, only used we need to clear only the }
{ stack }
{ also an exit label, only used we need to clear only the stack }
aktexit2label : plabel;
{ only used in constructor for fail or if getmem fails }
quickexitlabel : plabel;
{ this asm list contains the debug info }
{debuginfos : paasmoutput; debuglist is enough }
{ Boolean, wenn eine loadn kein Assembler erzeugt hat }
simple_loadn : boolean;
{ enth„lt die gesch„tzte Durchlaufanzahl*100 f<>r den }
{ momentan bearbeiteten Baum }
{ tries to hold the amount of times which the current tree is processed }
t_times : longint;
{ true, if an error while code generation occurs }
codegenerror : boolean;
{ some support routines for the case instruction }
{ initialize respectively terminates the code generator }
{ for a new module or procedure }
procedure codegen_doneprocedure;
procedure codegen_donemodule;
procedure codegen_newmodule;
procedure codegen_newprocedure;
{ counts the labels }
function case_count_labels(root : pcaserecord) : longint;
{ searches the highest label }
function case_get_max(root : pcaserecord) : longint;
{ searches the lowest label }
function case_get_min(root : pcaserecord) : longint;
{ concates the ASCII string to the data segment }
procedure generate_ascii(hs : string);
{ inserts the ASCII string to the data segment }
procedure generate_ascii_insert(hs : string);
{ concates the ASCII string from pchar to the data segment }
{ concates/inserts the ASCII string to the data segment }
procedure generate_ascii(const hs : string);
procedure generate_ascii_insert(const hs : string);
{ concates/inserts the ASCII string from pchar to the data segment }
{ WARNING : if hs has no #0 and strlen(hs)=length }
{ the terminal zero is not written }
procedure generate_pascii(hs : pchar;length : longint);
{ inserts the ASCII string from pchar to the data segment }
{ see WARNING above }
procedure generate_pascii_insert(hs : pchar;length : longint);
procedure generate_interrupt_stackframe_entry;
procedure generate_interrupt_stackframe_exit;
implementation
{ convert/concats a label for constants in the consts section }
function constlabel2str(p:plabel;ctype:tconsttype):string;
procedure concat_constlabel(p:plabel;ctype:tconsttype);
{$ifdef i386}
procedure generate_interrupt_stackframe_entry;
implementation
uses
cobjects,globals,files,strings;
{*****************************************************************************
initialize/terminate the codegen for procedure and modules
*****************************************************************************}
procedure codegen_newprocedure;
begin
{ save the registers of an interrupt procedure }
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EBX)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ECX)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDX)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
{ .... also the segment registers }
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_DS)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_ES)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_FS)));
procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_GS)));
aktbreaklabel:=nil;
aktcontinuelabel:=nil;
{ aktexitlabel:=0; is store in oldaktexitlabel
so it must not be reset to zero before this storage !}
{ the type of this lists isn't important }
{ because the code of this lists is }
{ copied to the code segment }
procinfo.aktentrycode:=new(paasmoutput,init);
procinfo.aktexitcode:=new(paasmoutput,init);
procinfo.aktproccode:=new(paasmoutput,init);
procinfo.aktlocaldata:=new(paasmoutput,init);
end;
procedure generate_interrupt_stackframe_exit;
procedure codegen_doneprocedure;
begin
{ restore the registers of an interrupt procedure }
{ this was all with entrycode instead of exitcode !!}
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EBX)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
{ .... also the segment registers }
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_DS)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_ES)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_FS)));
procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_GS)));
{ this restores the flags }
procinfo.aktexitcode^.concat(new(pai386,op_none(A_IRET,S_NO)));
end;
{$endif}
{$ifdef m68k}
procedure generate_interrupt_stackframe_entry;
begin
{ save the registers of an interrupt procedure }
{ .... also the segment registers }
dispose(procinfo.aktentrycode,done);
dispose(procinfo.aktexitcode,done);
dispose(procinfo.aktproccode,done);
dispose(procinfo.aktlocaldata,done);
end;
procedure generate_interrupt_stackframe_exit;
procedure codegen_newmodule;
begin
{ restore the registers of an interrupt procedure }
exprasmlist:=new(paasmoutput,init);
datasegment:=new(paasmoutput,init);
codesegment:=new(paasmoutput,init);
bsssegment:=new(paasmoutput,init);
debuglist:=new(paasmoutput,init);
externals:=new(paasmoutput,init);
internals:=new(paasmoutput,init);
consts:=new(paasmoutput,init);
rttilist:=new(paasmoutput,init);
importssection:=nil;
exportssection:=nil;
resourcesection:=nil;
end;
{$endif}
procedure generate_ascii(hs : string);
procedure codegen_donemodule;
begin
dispose(exprasmlist,done);
dispose(codesegment,done);
dispose(bsssegment,done);
dispose(datasegment,done);
dispose(debuglist,done);
dispose(externals,done);
dispose(consts,done);
dispose(rttilist,done);
if assigned(importssection) then
dispose(importssection,done);
if assigned(exportssection) then
dispose(exportssection,done);
if assigned(resourcesection) then
dispose(resourcesection,done);
end;
{*****************************************************************************
Case Helpers
*****************************************************************************}
function case_count_labels(root : pcaserecord) : longint;
var
_l : longint;
procedure count(p : pcaserecord);
begin
inc(_l);
if assigned(p^.less) then
count(p^.less);
if assigned(p^.greater) then
count(p^.greater);
end;
begin
while length(hs)>32 do
begin
datasegment^.concat(new(pai_string,init(copy(hs,1,32))));
delete(hs,1,32);
end;
_l:=0;
count(root);
case_count_labels:=_l;
end;
function case_get_max(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.greater) do
hp:=hp^.greater;
case_get_max:=hp^._high;
end;
function case_get_min(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.less) do
hp:=hp^.less;
case_get_min:=hp^._low;
end;
{*****************************************************************************
String Helpers
*****************************************************************************}
procedure generate_ascii(const hs : string);
begin
datasegment^.concat(new(pai_string,init(hs)))
end;
procedure generate_ascii_insert(hs : string);
procedure generate_ascii_insert(const hs : string);
begin
while length(hs)>32 do
begin
datasegment^.insert(new(pai_string,init(copy(hs,length(hs)-32+1,length(hs)))));
{ should be avoid very slow }
delete(hs,length(hs)-32+1,length(hs));
end;
datasegment^.insert(new(pai_string,init(hs)));
end;
function strnew(p : pchar;length : longint) : pchar;
function strnew(p : pchar;length : longint) : pchar;
var
pc : pchar;
begin
@ -251,12 +288,13 @@ unit hcodegen;
strnew:=pc;
end;
{ concates the ASCII string from pchar to the const segment }
procedure generate_pascii(hs : pchar;length : longint);
var
real_end,current_begin,current_end : pchar;
c :char;
begin
if assigned(hs) then
begin
@ -284,7 +322,6 @@ unit hcodegen;
var
real_end,current_begin,current_end : pchar;
c :char;
begin
if assigned(hs) then
begin
@ -308,56 +345,54 @@ unit hcodegen;
end;
function case_count_labels(root : pcaserecord) : longint;
{*****************************************************************************
Const Helpers
*****************************************************************************}
var
_l : longint;
procedure count(p : pcaserecord);
begin
inc(_l);
if assigned(p^.less) then
count(p^.less);
if assigned(p^.greater) then
count(p^.greater);
end;
const
consttypestr : array[tconsttype] of string[6]=
('ord','string','real','bool','int','char','set');
function constlabel2str(p:plabel;ctype:tconsttype):string;
begin
_l:=0;
count(root);
case_count_labels:=_l;
if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then
constlabel2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(p^.nb)
else
constlabel2str:=lab2str(p);
end;
function case_get_max(root : pcaserecord) : longint;
procedure concat_constlabel(p:plabel;ctype:tconsttype);
var
hp : pcaserecord;
s : string;
begin
hp:=root;
while assigned(hp^.greater) do
hp:=hp^.greater;
case_get_max:=hp^._high;
end;
function case_get_min(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.less) do
hp:=hp^.less;
case_get_min:=hp^._low;
if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then
begin
s:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(p^.nb);
if smartlink then
begin
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_symbol,init_global(s)))
end
else
consts^.concat(new(pai_symbol,init_global(s)));
end
else
consts^.concat(new(pai_label,init(p)));
end;
end.
{
$Log$
Revision 1.3 1998-05-06 08:38:40 pierre
Revision 1.4 1998-05-07 00:17:01 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.3 1998/05/06 08:38:40 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
@ -372,51 +407,4 @@ end.
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.1.1.1 1998/03/25 11:18:13 root
* Restored version
Revision 1.6 1998/03/10 16:27:38 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.5 1998/03/10 01:17:19 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.4 1998/03/02 01:48:37 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.3 1998/02/13 10:35:03 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.2 1998/01/16 18:03:15 florian
* small bug fixes, some stuff of delphi styled constructores added
Revision 1.1.1.1 1997/11/27 08:32:56 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History:
5th september 1997:
+ added support for MC68000 (CEC)
22th september 1997:
+ added tprocinfo member parent (FK)
}

113
compiler/tree.pas
View File

@ -276,6 +276,7 @@ unit tree;
function equal_trees(t1,t2 : ptree) : boolean;
procedure swaptree(p:Ptree);
procedure disposetree(p : ptree);
procedure putnode(p : ptree);
function getnode : ptree;
@ -464,6 +465,19 @@ unit tree;
dispose(p);
end;
procedure swaptree(p:Ptree);
var swapp:Ptree;
begin
swapp:=p^.right;
p^.right:=p^.left;
p^.left:=swapp;
p^.swaped:=not(p^.swaped);
end;
procedure disposetree(p : ptree);
begin
@ -1522,7 +1536,14 @@ unit tree;
end.
{
$Log$
Revision 1.7 1998-05-06 15:04:21 pierre
Revision 1.8 1998-05-07 00:17:01 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.7 1998/05/06 15:04:21 pierre
+ when trying to find source files of a ppufile
check the includepathlist for included files
the main file must still be in the same directory
@ -1557,95 +1578,5 @@ end.
Revision 1.2 1998/04/07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.1.1.1 1998/03/25 11:18:13 root
* Restored version
Revision 1.15 1998/03/24 21:48:36 florian
* just a couple of fixes applied:
- problem with fixed16 solved
- internalerror 10005 problem fixed
- patch for assembler reading
- small optimizer fix
- mem is now supported
Revision 1.14 1998/03/10 16:27:46 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.13 1998/03/10 01:17:30 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.12 1998/03/02 01:49:37 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.11 1998/02/27 09:26:18 daniel
* Changed symtable handling so no junk symtable is put on the symtablestack.
Revision 1.10 1998/02/13 10:35:54 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.9 1998/02/12 11:50:51 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.8 1998/02/04 14:39:31 florian
* small clean up
Revision 1.7 1998/01/13 23:11:16 florian
+ class methods
Revision 1.6 1998/01/11 04:16:36 carl
+ correct floating point support for m68k
Revision 1.5 1998/01/07 00:17:11 michael
Restored released version (plus fixes) as current
Revision 1.3 1997/12/04 12:02:15 pierre
+ added a counter of max firstpass's for a ptree
for debugging only in ifdef extdebug
Revision 1.2 1997/11/29 15:43:08 florian
* some minor changes
Revision 1.1.1.1 1997/11/27 08:33:03 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History:
19th october 1996:
+ adapted to version 0.9.0
6th september 1997:
+ added support for MC68000 (CEC)
3rd october 1997:
+ added tc_bool_2_u8bit for in_ord_x (PM)
3rd november1997:
+ added symdifn for sets (PM)
13th november 1997:
+ added partial code for u32bit support (PM)
}