paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 01:39:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* smartlinking works for win32

Browse Source 
* some defines to exclude some compiler parts
This commit is contained in:
peter 1998-06-08 22:59:41 +00:00
parent 837c1582a3
commit f98459e1fb
12 changed files with 483 additions and 1802 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
compiler/aasm.pas
View File

@ -123,6 +123,7 @@ unit aasm;
plabel = ^tlabel;
tlabel = record
nb : longint;
is_data : boolean;
is_used : boolean;
is_set : boolean;
refcount : word;
@ -285,6 +286,8 @@ type
function lab2str(l : plabel) : string;
{ make l as a new label }
procedure getlabel(var l : plabel);
{ make l as a new label and flag is_data }
procedure getdatalabel(var l : plabel);
{ frees the label if unused }
procedure freelabel(var l : plabel);
{ make a new zero label }
@ -585,18 +588,15 @@ uses
typ:=ait_label;
l:=_l;
l^.is_set:=true;
{ suggestion of JM:
inc(l^.refcount); }
end;
destructor tai_label.done;
begin
{ suggestion of JM:
dec(l^.refcount); }
if (l^.is_used) then
l^.is_set:=false
else dispose(l);
else
dispose(l);
inherited done;
end;
@ -751,15 +751,20 @@ uses
function lab2str(l : plabel) : string;
begin
if (l=nil) or (l^.nb=0) then
begin
{$ifdef EXTDEBUG}
lab2str:='ILLEGAL'
else
lab2str:=target_asm.labelprefix+tostr(l^.nb);
lab2str:='ILLEGAL'
{$else EXTDEBUG}
internalerror(2000);
lab2str:=target_asm.labelprefix+tostr(l^.nb);
internalerror(2000);
{$endif EXTDEBUG}
{ was missed: }
end
else
begin
if (l^.is_data) and (cs_smartlink in aktswitches) then
lab2str:='_$'+current_module^.modulename^+'$_L'+tostr(l^.nb)
else
lab2str:=target_asm.labelprefix+tostr(l^.nb);
end;
inc(l^.refcount);
l^.is_used:=true;
end;
@ -771,6 +776,19 @@ uses
l^.nb:=nextlabelnr;
l^.is_used:=false;
l^.is_set:=false;
l^.is_data:=false;
l^.refcount:=0;
inc(nextlabelnr);
end;
procedure getdatalabel(var l : plabel);
begin
new(l);
l^.nb:=nextlabelnr;
l^.is_used:=false;
l^.is_set:=false;
l^.is_data:=true;
l^.refcount:=0;
inc(nextlabelnr);
end;
@ -791,6 +809,7 @@ uses
nb:=0;
is_used:=false;
is_set:=false;
is_data:=false;
refcount:=0;
end;
end;
@ -802,6 +821,7 @@ uses
l^.nb:=0;
l^.is_used:=false;
l^.is_set:=false;
l^.is_data:=false;
l^.refcount:=0;
end;
@ -817,7 +837,11 @@ uses
end.
{
$Log$
Revision 1.9 1998-06-04 23:51:26 peter
Revision 1.10 1998-06-08 22:59:41 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.9 1998/06/04 23:51:26 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32

46
compiler/assemble.pas
View File

@ -45,6 +45,7 @@ type
srcfile,
as_bin : string;
{outfile}
AsmSize,
outcnt : longint;
outbuf : array[0..AsmOutSize-1] of char;
outfile : file;
@ -82,10 +83,26 @@ uses
{$endif}
,strings
{$ifdef i386}
,ag386att,ag386int,ag386nsm
{$ifndef NoAg386Att}
,ag386att
{$endif NoAg386Att}
{$ifndef NoAg386Nsm}
,ag386nsm
{$endif NoAg386Nsm}
{$ifndef NoAg386Int}
,ag386int
{$endif NoAg386Int}
{$endif}
{$ifdef m68k}
,ag68kmot,ag68kgas,ag68kmit
{$ifndef NoAg68kGas}
,ag68kgas
{$endif NoAg68kGas}
{$ifndef NoAg68kMot}
,ag68kmot
{$endif NoAg68kMot}
{$ifndef NoAg68kMit}
,ag68kmit
{$endif NoAg68kMit}
{$endif}
;
@ -231,6 +248,7 @@ begin
AsmFlush;
Move(s[1],OutBuf[OutCnt],length(s));
inc(OutCnt,length(s));
inc(AsmSize,length(s));
end;
@ -254,6 +272,7 @@ begin
AsmFlush;
Move(p[0],OutBuf[OutCnt],i);
inc(OutCnt,i);
inc(AsmSize,i);
dec(j,i);
p:=pchar(@p[i]);
end;
@ -266,10 +285,12 @@ begin
AsmFlush;
OutBuf[OutCnt]:=target_os.newline[1];
inc(OutCnt);
inc(AsmSize);
if length(target_os.newline)>1 then
begin
OutBuf[OutCnt]:=target_os.newline[2];
inc(OutCnt);
inc(AsmSize);
end;
end;
@ -295,6 +316,7 @@ begin
Message1(exec_d_cant_create_asmfile,asmfile);
end;
outcnt:=0;
AsmSize:=0;
end;
@ -380,20 +402,32 @@ var
begin
case aktoutputformat of
{$ifdef i386}
{$ifndef NoAg386Att}
as_o : a:=new(pi386attasmlist,Init(fn));
{$endif NoAg386Att}
{$ifndef NoAg386Nsm}
as_nasmcoff,
as_nasmelf,
as_nasmobj : a:=new(pi386nasmasmlist,Init(fn));
{$endif NoAg386Nsm}
{$ifndef NoAg386Int}
as_tasm : a:=new(pi386intasmlist,Init(fn));
{$endif NoAg386Int}
{$endif}
{$ifdef m68k}
{$ifndef NoAg68kGas}
as_o,
as_gas : a:=new(pm68kgasasmlist,Init(fn));
{$endif NoAg86KGas}
{$ifndef NoAg68kMot}
as_mot : a:=new(pm68kmotasmlist,Init(fn));
{$endif NoAg86kMot}
{$ifndef NoAg68kMit}
as_mit : a:=new(pm68kmitasmlist,Init(fn));
{$endif NoAg86KMot}
{$endif}
else
internalerror(30000);
Comment(V_Fatal,'Selected assembler output not supported!');
end;
a^.AsmCreate;
a^.WriteAsmList;
@ -416,7 +450,11 @@ end;
end.
{
$Log$
Revision 1.10 1998-06-04 23:51:33 peter
Revision 1.11 1998-06-08 22:59:43 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.10 1998/06/04 23:51:33 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32

63
compiler/cgi3862.pas
View File

@ -1,63 +0,0 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
This unit generates i386 (or better) assembler from the parse tree
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{$ifdef tp}
{$E+,F+,N+,D+,L+,Y+}
{$endif}
unit cgi3862;
interface
uses
verbose,cobjects,systems,globals,tree,
symtable,types,strings,pass_1,hcodegen,
aasm,i386,tgeni386,files,cgai386;
procedure secondadd(var p : ptree);
procedure secondaddstring(var p : ptree);
procedure secondas(var p : ptree);
procedure secondis(var p : ptree);
procedure secondloadvmt(var p : ptree);
implementation
uses
cgi386;
{$I cgi386ad.inc}
end.
{
$Log$
Revision 1.2 1998-04-21 10:16:47 peter
* patches from strasbourg
* objects is not used anymore in the fpc compiled version
Revision 1.1.1.1 1998/03/25 11:18:12 root
* Restored version
Revision 1.9 1998/03/10 01:17:18 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
}

1323
compiler/cgi386ad.inc
View File

File diff suppressed because it is too large Load Diff

16
compiler/link.pas
View File

@ -304,7 +304,7 @@ begin
AddSharedLibrary('c');
end;
end;
{$endif}
{$endif}
end;
@ -434,19 +434,23 @@ end;
Procedure TLinker.MakeStaticLibrary(const path:string;filescnt:longint);
var
s,
arbin : string;
arfound : boolean;
cnt : longint;
i : word;
f : file;
begin
arbin:=FindExe('ar',arfound);
arbin:=FindExe(target_ar.arbin,arfound);
if (not arfound) and (not externlink) then
begin
Message(exec_w_ar_not_found);
externlink:=true;
end;
DoExec(arbin,'rs '+staticlibname+' '+FixPath(path)+'*'+target_info.objext,false,true);
s:=target_ar.arcmd;
Replace(s,'$LIB',staticlibname);
Replace(s,'$FILES',FixPath(path)+'*'+target_info.objext);
DoExec(arbin,s,false,true);
{ Clean up }
if (not writeasmfile) and (not externlink) then
begin
@ -475,7 +479,11 @@ end;
end.
{
$Log$
Revision 1.12 1998-06-04 23:51:44 peter
Revision 1.13 1998-06-08 22:59:46 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.12 1998/06/04 23:51:44 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32

11
compiler/parser.pas
View File

@ -34,7 +34,7 @@ unit parser;
uses
systems,cobjects,globals,verbose,
symtable,files,aasm,hcodegen,import,
symtable,files,aasm,hcodegen,
assemble,link,script,gendef,
scanner,pbase,pdecl,psystem,pmodules;
@ -312,9 +312,6 @@ unit parser;
if status.errorcount=0 then
begin
if current_module^.uses_imports then
importlib^.generatelib;
GenerateAsm(filename);
if (cs_smartlink in aktswitches) then
@ -442,7 +439,11 @@ done:
end.
{
$Log$
Revision 1.22 1998-06-05 17:47:28 peter
Revision 1.23 1998-06-08 22:59:48 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.22 1998/06/05 17:47:28 peter
* some better uses clauses
Revision 1.21 1998/06/04 23:51:49 peter

60
compiler/pmodules.pas
View File

@ -39,7 +39,7 @@ unit pmodules;
uses
cobjects,verbose,systems,globals,
symtable,aasm,hcodegen,
link,assemble
link,assemble,import
{$ifdef i386}
,i386
{$endif}
@ -63,6 +63,15 @@ unit pmodules;
end;
procedure insertsegment;
procedure fixseg(p:paasmoutput;sec:tsection);
begin
p^.insert(new(pai_section,init(sec)));
if (cs_smartlink in aktswitches) then
p^.insert(new(pai_cut,init));
p^.concat(new(pai_section,init(sec_none)));
end;
begin
{Insert Ident of the compiler}
if (not (cs_smartlink in aktswitches))
@ -75,15 +84,10 @@ unit pmodules;
datasegment^.insert(new(pai_string,init('FPC '+version_string+' for '+target_string+' - '+target_info.short_name)));
end;
{ Insert start and end of sections }
codesegment^.insert(new(pai_section,init(sec_code)));
codesegment^.concat(new(pai_section,init(sec_none)));
datasegment^.insert(new(pai_section,init(sec_data)));
datasegment^.concat(new(pai_section,init(sec_none)));
bsssegment^.insert(new(pai_section,init(sec_bss)));
bsssegment^.concat(new(pai_section,init(sec_none)));
consts^.insert(new(pai_asm_comment,init('Constants')));
consts^.insert(new(pai_section,init(sec_data)));
consts^.concat(new(pai_section,init(sec_none)));
fixseg(codesegment,sec_code);
fixseg(datasegment,sec_data);
fixseg(bsssegment,sec_bss);
fixseg(consts,sec_data);
end;
procedure insertheap;
@ -101,14 +105,11 @@ unit pmodules;
not output a pointer }
case target_info.target of
{$ifdef i386}
target_OS2 : ;
{$endif i386}
{$ifdef m68k}
target_Mac68K : bsssegment^.concat(new(pai_datablock,init_global('HEAP',4)));
{$endif m68k}
else
bsssegment^.concat(new(pai_datablock,init_global('HEAP',heapsize)));
end;
@ -122,7 +123,6 @@ unit pmodules;
i : longint;
begin
{$ifdef i386}
case target_info.target of
target_GO32V2 : begin
{ stacksize can be specified }
@ -130,14 +130,17 @@ unit pmodules;
datasegment^.concat(new(pai_const,init_32bit(stacksize)));
end;
target_WIN32 : begin
{ generate the last entry for the imports directory }
if not(assigned(importssection)) then
{ Generate an external entry to be sure that _mainCRTStarup will be
linked, can't use concat_external because those aren't written for
asw (PFV) }
datasegment^.concat(new(pai_const,init_symbol('_mainCRTStartup')));
{ generate the last entry for the imports directory, is done
in the ld script }
{ if not(assigned(importssection)) then
importssection:=new(paasmoutput,init);
{ $3 ensure that it is the last entry, all other entries }
{ are written to $2 }
importssection^.concat(new(pai_section,init_idata(3)));
for i:=1 to 5 do
importssection^.concat(new(pai_const,init_32bit(0)));
importssection^.concat(new(pai_const,init_32bit(0))); }
end;
end;
{$endif i386}
@ -845,6 +848,11 @@ unit pmodules;
pu:=pused_unit(pu^.next);
end;
inc(datasize,symtablestack^.datasize);
{ generate imports }
if current_module^.uses_imports then
importlib^.generatelib;
{ finish asmlist by adding segment starts }
insertsegment;
end;
@ -967,7 +975,13 @@ unit pmodules;
else
current_module^.linkofiles.insert(current_module^.objfilename^);
{ insert heap }
insertheap;
{ generate imports }
if current_module^.uses_imports then
importlib^.generatelib;
inserttargetspecific;
datasize:=symtablestack^.datasize;
@ -979,7 +993,11 @@ unit pmodules;
end.
{
$Log$
Revision 1.24 1998-06-08 13:13:44 pierre
Revision 1.25 1998-06-08 22:59:49 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.24 1998/06/08 13:13:44 pierre
+ temporary variables now in temp_gen.pas unit
because it is processor independent
* mppc68k.bat modified to undefine i386 and support_mmx
@ -1000,8 +1018,6 @@ end.
Revision 1.20 1998/06/04 09:55:42 pierre
* demangled name of procsym reworked to become independant of the mangling scheme
Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
Revision 1.19 1998/06/03 23:40:38 peter
+ unlimited file support, release tempclose

396
compiler/pstatmnt.pas
View File

@ -39,42 +39,42 @@ unit pstatmnt;
implementation
uses
cobjects,scanner,globals,symtable,aasm,pass_1,
types,hcodegen,files,verbose,systems
cobjects,globals,files,verbose,systems,
symtable,aasm,pass_1,types,scanner,hcodegen
{$ifdef NEWPPU}
,ppu
{$endif}
{ processor specific stuff }
,pbase,pexpr,pdecl
{$ifdef i386}
,i386
,i386,tgeni386
{$ifndef NoRa386Int}
,rai386
{$endif NoRa386Int}
{$ifndef NoRa386Att}
,ratti386
{$endif NoRa386Att}
{$ifndef NoRa386Dir}
,radi386
,tgeni386
{$endif}
{$endif NoRa386Dir}
{$endif i386}
{$ifdef m68k}
,m68k
,tgen68k
,ag68kmit
,m68k,tgen68k
{$ifndef NoRa68kMot}
,ra68k
,ag68kgas
,ag68kmot
{$endif}
{ parser specific stuff, be careful consume is also defined to }
{ read assembler tokens }
,pbase,pexpr,pdecl;
{$endif NoRa68kMot}
{$endif m68k}
;
const
statement_level : longint = 0;
function statement : ptree;forward;
function if_statement : ptree;
function if_statement : ptree;
var
ex,if_a,else_a : ptree;
begin
consume(_IF);
ex:=comp_expr(true);
@ -257,6 +257,7 @@ unit pstatmnt;
case_statement:=code;
end;
function repeat_statement : ptree;
var
@ -293,6 +294,7 @@ unit pstatmnt;
repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
end;
function while_statement : ptree;
var
@ -306,6 +308,7 @@ unit pstatmnt;
while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
end;
function for_statement : ptree;
var
@ -334,6 +337,7 @@ unit pstatmnt;
for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
end;
function _with_statement : ptree;
var
@ -434,6 +438,7 @@ unit pstatmnt;
_with_statement:=genwithnode(withsymtable,p,right,levelcount);
end;
function with_statement : ptree;
begin
@ -441,6 +446,7 @@ unit pstatmnt;
with_statement:=_with_statement;
end;
function raise_statement : ptree;
var
@ -467,6 +473,7 @@ unit pstatmnt;
raise_statement:=gennode(raisen,p1,p2);
end;
function try_statement : ptree;
var
@ -558,6 +565,7 @@ unit pstatmnt;
end;
end;
function exit_statement : ptree;
var
@ -581,11 +589,9 @@ unit pstatmnt;
end;
{$ifdef i386}
function _asm_statement : ptree;
var asm_stat : ptree;
var
asmstat : ptree;
begin
if (aktprocsym^.definition^.options and poinline)<>0 then
Begin
@ -594,25 +600,38 @@ unit pstatmnt;
aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline;
End;
case aktasmmode of
I386_ATT : asm_stat:=ratti386.assemble;
I386_INTEL : asm_stat:=rai386.assemble;
I386_DIRECT : asm_stat:=radi386.assemble;
else internalerror(30004);
{$ifdef i386}
{$ifndef NoRA386Att}
I386_ATT : asmstat:=ratti386.assemble;
{$endif NoRA386Att}
{$ifndef NoRA386Int}
I386_INTEL : asmstat:=rai386.assemble;
{$endif NoRA386Int}
{$ifndef NoRA386Dir}
I386_DIRECT : asmstat:=radi386.assemble;
{$endif NoRA386Dir}
{$endif}
{$ifdef m68k}
{$ifndef NoRA68kMot}
M68K_MOT : asmstat:=ra68k.assemble;
{$endif NoRA68kMot}
{$endif}
else
Comment(V_Fatal,'Selected assembler reader not supported');
end;
{ Erst am Ende _ASM konsumieren, da der Scanner sonst die }
{ erste Assemblerstatement zu lesen versucht! }
{ Read first the _ASM statement }
consume(_ASM);
{ (END is read) }
{ END is read }
if token=LECKKLAMMER then
begin
{ it's possible to specify the modified registers }
consume(LECKKLAMMER);
asm_stat^.object_preserved:=true;
asmstat^.object_preserved:=true;
if token<>RECKKLAMMER then
repeat
pattern:=upper(pattern);
{$ifdef i386}
if pattern='EAX' then
usedinproc:=usedinproc or ($80 shr byte(R_EAX))
else if pattern='EBX' then
@ -624,41 +643,12 @@ unit pstatmnt;
else if pattern='ESI' then
begin
usedinproc:=usedinproc or ($80 shr byte(R_ESI));
asm_stat^.object_preserved:=false;
asmstat^.object_preserved:=false;
end
else if pattern='EDI' then
usedinproc:=usedinproc or ($80 shr byte(R_EDI))
else consume(RECKKLAMMER);
consume(CSTRING);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
end
else usedinproc:=$ff;
_asm_statement:=asm_stat;
end;
{$endif}
{$endif i386}
{$ifdef m68k}
function _asm_statement : ptree;
begin
_asm_statement:= ra68k.assemble;
{ Erst am Ende _ASM konsumieren, da der Scanner sonst die }
{ erste Assemblerstatement zu lesen versucht! }
consume(_ASM);
{ (END is read) }
if token=LECKKLAMMER then
begin
{ it's possible to specify the modified registers }
{ we only check the registers which are not reserved }
{ and which can be used. This is done for future }
{ optimizations. }
consume(LECKKLAMMER);
if token<>RECKKLAMMER then
repeat
pattern:=upper(pattern);
if pattern='D0' then
usedinproc:=usedinproc or ($800 shr word(R_D0))
else if pattern='D1' then
@ -669,6 +659,7 @@ unit pstatmnt;
usedinproc:=usedinproc or ($800 shr word(R_A0))
else if pattern='A1' then
usedinproc:=usedinproc or ($800 shr word(R_A1))
{$endif m68k}
else consume(RECKKLAMMER);
consume(CSTRING);
if token=COMMA then consume(COMMA)
@ -676,155 +667,153 @@ unit pstatmnt;
until false;
consume(RECKKLAMMER);
end
else usedinproc:=$ffff;
end;
{$endif}
else usedinproc:=$ff;
_asm_statement:=asmstat;
end;
function new_dispose_statement : ptree;
var
p,p2 : ptree;
ht : ttoken;
again : boolean; { dummy for do_proc_call }
destrukname : stringid;
sym : psym;
classh : pobjectdef;
pd,pd2 : pdef;
store_valid : boolean;
tt : ttreetyp;
begin
ht:=token;
if token=_NEW then consume(_NEW)
else consume(_DISPOSE);
if ht=_NEW then
tt:=hnewn
else
tt:=hdisposen;
consume(LKLAMMER);
p:=comp_expr(true);
var
p,p2 : ptree;
ht : ttoken;
again : boolean; { dummy for do_proc_call }
destrukname : stringid;
sym : psym;
classh : pobjectdef;
pd,pd2 : pdef;
store_valid : boolean;
tt : ttreetyp;
{ calc return type }
cleartempgen;
Store_valid := Must_be_valid;
Must_be_valid := False;
do_firstpass(p);
Must_be_valid := Store_valid;
begin
ht:=token;
if token=_NEW then consume(_NEW)
else consume(_DISPOSE);
if ht=_NEW then
tt:=hnewn
else
tt:=hdisposen;
consume(LKLAMMER);
p:=comp_expr(true);
{var o:Pobject;
begin
new(o,init); (*Also a valid new statement*)
end;}
{ calc return type }
cleartempgen;
Store_valid := Must_be_valid;
Must_be_valid := False;
do_firstpass(p);
Must_be_valid := Store_valid;
if token=COMMA then
begin
{ extended syntax of new and dispose }
{ function styled new is handled in factor }
consume(COMMA);
{ destructors have no parameters }
destrukname:=pattern;
consume(ID);
{var o:Pobject;
pd:=p^.resulttype;
pd2:=pd;
if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
begin
Message(parser_e_pointer_type_expected);
p:=factor(false);
consume(RKLAMMER);
new_dispose_statement:=genzeronode(errorn);
exit;
end;
{ first parameter must be an object or class }
if ppointerdef(pd)^.definition^.deftype<>objectdef then
begin
Message(parser_e_pointer_to_class_expected);
new_dispose_statement:=factor(false);
consume_all_until(RKLAMMER);
consume(RKLAMMER);
exit;
end;
{ check, if the first parameter is a pointer to a _class_ }
classh:=pobjectdef(ppointerdef(pd)^.definition);
if (classh^.options and oois_class)<>0 then
begin
Message(parser_e_no_new_or_dispose_for_classes);
new_dispose_statement:=factor(false);
{ while token<>RKLAMMER do
consume(token); }
consume_all_until(RKLAMMER);
consume(RKLAMMER);
exit;
end;
{ search cons-/destructor, also in parent classes }
sym:=nil;
while assigned(classh) do
begin
sym:=classh^.publicsyms^.search(pattern);
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
{ the second parameter of new/dispose must be a call }
{ to a cons-/destructor }
if (sym^.typ<>procsym) then
begin
Message(parser_e_expr_have_to_be_destructor_call);
new_dispose_statement:=genzeronode(errorn);
end
else
begin
p2:=gensinglenode(tt,p);
if ht=_NEW then
begin
{ Constructors can take parameters.}
p2^.resulttype:=ppointerdef(pd)^.definition;
do_member_read(sym,p2,pd,again);
end
else
{ destructors can't.}
p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
begin
new(o,init); (*Also a valid new statement*)
end;}
{ we need the real called method }
cleartempgen;
do_firstpass(p2);
if token=COMMA then
begin
{ extended syntax of new and dispose }
{ function styled new is handled in factor }
consume(COMMA);
{ destructors have no parameters }
destrukname:=pattern;
consume(ID);
if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
Message(parser_e_expr_have_to_be_constructor_call);
if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
Message(parser_e_expr_have_to_be_destructor_call);
pd:=p^.resulttype;
pd2:=pd;
if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
begin
Message(parser_e_pointer_type_expected);
p:=factor(false);
consume(RKLAMMER);
new_dispose_statement:=genzeronode(errorn);
exit;
end;
{ first parameter must be an object or class }
if ppointerdef(pd)^.definition^.deftype<>objectdef then
begin
Message(parser_e_pointer_to_class_expected);
new_dispose_statement:=factor(false);
consume_all_until(RKLAMMER);
consume(RKLAMMER);
exit;
end;
{ check, if the first parameter is a pointer to a _class_ }
classh:=pobjectdef(ppointerdef(pd)^.definition);
if (classh^.options and oois_class)<>0 then
begin
Message(parser_e_no_new_or_dispose_for_classes);
new_dispose_statement:=factor(false);
{ while token<>RKLAMMER do
consume(token); }
consume_all_until(RKLAMMER);
consume(RKLAMMER);
exit;
end;
{ search cons-/destructor, also in parent classes }
sym:=nil;
while assigned(classh) do
begin
sym:=classh^.publicsyms^.search(pattern);
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
{ the second parameter of new/dispose must be a call }
{ to a cons-/destructor }
if (sym^.typ<>procsym) then
begin
Message(parser_e_expr_have_to_be_destructor_call);
new_dispose_statement:=genzeronode(errorn);
end
else
begin
p2:=gensinglenode(tt,p);
if ht=_NEW then
begin
{ Constructors can take parameters.}
p2^.resulttype:=ppointerdef(pd)^.definition;
do_member_read(sym,p2,pd,again);
end
else
{ destructors can't.}
p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
if ht=_NEW then
begin
p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
p2^.right^.resulttype:=pd2;
end;
new_dispose_statement:=p2;
end;
end
else
begin
if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
Begin
Message(parser_e_pointer_type_expected);
new_dispose_statement:=genzeronode(errorn);
end
else
begin
if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
Message(parser_w_use_extended_syntax_for_objects);
{ we need the real called method }
cleartempgen;
do_firstpass(p2);
case ht of
_NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
_DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
end;
end;
end;
consume(RKLAMMER);
end;
if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
Message(parser_e_expr_have_to_be_constructor_call);
if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
Message(parser_e_expr_have_to_be_destructor_call);
if ht=_NEW then
begin
p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
p2^.right^.resulttype:=pd2;
end;
new_dispose_statement:=p2;
end;
end
else
begin
if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
Begin
Message(parser_e_pointer_type_expected);
new_dispose_statement:=genzeronode(errorn);
end
else
begin
if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
Message(parser_w_use_extended_syntax_for_objects);
case ht of
_NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
_DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
end;
end;
end;
consume(RKLAMMER);
end;
function statement_block : ptree;
@ -874,6 +863,7 @@ unit pstatmnt;
statement_block:=last;
end;
function statement : ptree;
var
@ -1146,15 +1136,17 @@ unit pstatmnt;
end.
{
$Log$
Revision 1.18 1998-06-05 14:37:35 pierre
Revision 1.19 1998-06-08 22:59:50 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.18 1998/06/05 14:37:35 pierre
* fixes for inline for operators
* inline procedure more correctly restricted
Revision 1.17 1998/06/04 09:55:43 pierre
* demangled name of procsym reworked to become independant of the mangling scheme
Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
Revision 1.16 1998/06/02 17:03:04 pierre
* with node corrected for objects
* small bugs for SUPPORT_MMX fixed

164
compiler/ptconst.pas
View File

@ -156,52 +156,56 @@ unit ptconst;
if p^.treetype=niln then
datasegment^.concat(new(pai_const,init_32bit(0)))
{ maybe pchar ? }
else if (ppointerdef(def)^.definition^.deftype=orddef) and
else
if (ppointerdef(def)^.definition^.deftype=orddef) and
(porddef(ppointerdef(def)^.definition)^.typ=uchar) then
begin
getlabel(ll);
{ insert string at the begin }
if p^.treetype=stringconstn then
generate_ascii_insert((p^.values^)+#0)
else if is_constcharnode(p) then
datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
else Message(cg_e_illegal_expression);
datasegment^.insert(new(pai_label,init(ll)));
{ insert label }
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
begin
getlabel(ll);
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
datasegment^.concat(new(pai_label,init(ll)));
{ insert string at the begin }
if p^.treetype=stringconstn then
datasegment^.concat(new(pai_string,init(p^.values^+#0)))
else
if is_constcharnode(p) then
datasegment^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
else
Message(cg_e_illegal_expression);
{ insert label }
end
else if p^.treetype=addrn then
begin
if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
(is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
(is_equal(ppointerdef(def)^.definition,voiddef))) and
(p^.left^.treetype = loadn) then
begin
else
if p^.treetype=addrn then
begin
if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
(is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
(is_equal(ppointerdef(def)^.definition,voiddef))) and
(p^.left^.treetype = loadn) then
begin
datasegment^.concat(new(pai_const,init_symbol(
strpnew(p^.left^.symtableentry^.mangledname))));
maybe_concat_external(p^.left^.symtableentry^.owner,
p^.left^.symtableentry^.mangledname);
end
else
Message(cg_e_illegal_expression);
end
end
else
Message(cg_e_illegal_expression);
end
else
{ allow typeof(Object type)}
if (p^.treetype=inlinen) and
(p^.inlinenumber=in_typeof_x) then
if (p^.left^.treetype=typen) then
begin
datasegment^.concat(new(pai_const,init_symbol(
strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
begin
if (p^.left^.treetype=typen) then
begin
datasegment^.concat(new(pai_const,init_symbol(
strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
end
else
begin
Message(cg_e_illegal_expression);
end
else
Message(cg_e_illegal_expression);
end
else
Message(cg_e_illegal_expression);
end
else
Message(cg_e_illegal_expression);
disposetree(p);
end;
setdef:
@ -215,9 +219,8 @@ unit ptconst;
Message(cg_e_illegal_expression)
else
begin
for l:=0 to def^.savesize-1 do
datasegment^.concat(
new(pai_const,init_8bit(p^.constset^[l])));
for l:=0 to def^.savesize-1 do
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[l])));
end;
end
else
@ -225,15 +228,13 @@ unit ptconst;
disposetree(p);
end;
enumdef:
begin
begin
p:=comp_expr(true);
do_firstpass(p);
if p^.treetype=ordconstn then
begin
if is_equal(p^.resulttype,def) then
begin
datasegment^.concat(new(pai_const,init_32bit(p^.value)));
end
datasegment^.concat(new(pai_const,init_32bit(p^.value)))
else
Message(cg_e_illegal_expression);
end
@ -450,7 +451,11 @@ unit ptconst;
end.
{
$Log$
Revision 1.5 1998-06-03 22:49:01 peter
Revision 1.6 1998-06-08 22:59:52 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.5 1998/06/03 22:49:01 peter
+ wordbool,longbool
* rename bis,von -> high,low
* moved some systemunit loading/creating to psystem.pas
@ -467,77 +472,4 @@ end.
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.2 1998/04/07 13:19:48 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation
support for rhgdb.exe (lowercase file names)
Revision 1.1.1.1 1998/03/25 11:18:15 root
* Restored version
Revision 1.13 1998/03/20 23:31:35 florian
* bug0113 fixed
* problem with interdepened units fixed ("options.pas problem")
* two small extensions for future AMD 3D support
Revision 1.12 1998/03/18 22:50:11 florian
+ fstp/fld optimization
* routines which contains asm aren't longer optimzed
* wrong ifdef TEST_FUNCRET corrected
* wrong data generation for array[0..n] of char = '01234'; fixed
* bug0097 is fixed partial
* bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
65535)
Revision 1.11 1998/03/13 22:45:59 florian
* small bug fixes applied
Revision 1.10 1998/03/11 11:23:57 florian
* bug0081 and bug0109 fixed
Revision 1.9 1998/03/10 01:17:25 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.8 1998/03/06 00:52:50 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.7 1998/03/02 01:49:10 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.6 1998/02/13 10:35:33 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.5 1998/02/12 11:50:32 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.4 1998/01/24 23:08:19 carl
+ compile time range checking should logically always be on!
Revision 1.3 1998/01/23 17:12:20 pierre
* added some improvements for as and ld :
- doserror and dosexitcode treated separately
- PATH searched if doserror=2
+ start of long and ansi string (far from complete)
in conditionnal UseLongString and UseAnsiString
* options.pas cleaned (some variables shifted to globals)gl
Revision 1.2 1998/01/09 09:10:03 michael
+ Initial implementation, second try
}

14
compiler/symsym.inc
View File

@ -1269,10 +1269,10 @@
procedure ttypedconstsym.really_insert_in_data;
begin
if (cs_smartlink in aktswitches) then
datasegment^.concat(new(pai_cut,init));
if owner^.symtabletype=globalsymtable then
begin
if (cs_smartlink in aktswitches) then
datasegment^.concat(new(pai_cut,init));
{$ifdef GDB}
if cs_debuginfo in aktswitches then
concatstabto(datasegment);
@ -1282,6 +1282,8 @@
else
if owner^.symtabletype<>unitsymtable then
begin
if (cs_smartlink in aktswitches) then
datasegment^.concat(new(pai_cut,init));
{$ifdef GDB}
if cs_debuginfo in aktswitches then
concatstabto(datasegment);
@ -1692,7 +1694,11 @@
{
$Log$
Revision 1.5 1998-06-04 23:52:02 peter
Revision 1.6 1998-06-08 22:59:53 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.5 1998/06/04 23:52:02 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32
@ -1700,8 +1706,6 @@
Revision 1.4 1998/06/04 09:55:46 pierre
* demangled name of procsym reworked to become independant of the mangling scheme
Come test_funcret improvements (not yet working)S: ----------------------------------------------------------------------
Revision 1.3 1998/06/03 22:14:20 florian
* problem with sizes of classes fixed (if the anchestor was declared
forward, the compiler doesn't update the child classes size)

87
compiler/systems.pas
View File

@ -76,6 +76,15 @@ unit systems;
{$endif}
);
tar = (
{$ifdef i386}
ar_ar,ar_arw
{$endif}
{$ifdef m68k}
ar_ar
{$endif}
);
tos = (
{$ifdef i386}
@ -127,6 +136,11 @@ unit systems;
libprefix : string[2];
end;
tarinfo = record
arbin : string[8];
arcmd : string[50];
end;
ttargetinfo = record
target : ttarget;
short_name : string[8];
@ -141,6 +155,7 @@ unit systems;
os : tos;
link : tlink;
assem : tasm;
ar : tar;
end;
tasmmodeinfo=record
@ -153,6 +168,7 @@ unit systems;
target_os : tosinfo;
target_asm : tasminfo;
target_link : tlinkinfo;
target_ar : tarinfo;
source_os : tosinfo;
function set_string_target(const s : string) : boolean;
@ -168,7 +184,6 @@ implementation
****************************************************************************}
os_infos : array[tos] of tosinfo = (
{$ifdef i386}
(
name : 'GO32 V1 DOS extender';
sharedlibext : '.DLL';
@ -234,8 +249,7 @@ implementation
endian : endian_little;
use_function_relative_addresses : true
)
{$endif i386}
{$endif i386}
{$ifdef m68k}
(
name : 'Commodore Amiga';
@ -291,7 +305,7 @@ implementation
)
{$endif m68k}
);
{****************************************************************************
Assembler Info
@ -493,8 +507,29 @@ implementation
inputend : ')';
libprefix : '-l'
)
{$endif m68k}
{$endif m68k}
);
{****************************************************************************
Ar Info
****************************************************************************}
ar_infos : array[tar] of tarinfo = (
{$ifdef i386}
(
arbin : 'ar';
arcmd : 'rs $LIB $FILES'
),
(
arbin : 'arw';
arcmd : 'rs $LIB $FILES'
)
{$endif i386}
{$ifdef m68k}
(
arbin : 'ar';
arcmd : 'rs $LIB $FILES'
)
{$endif m68k}
);
{****************************************************************************
@ -502,7 +537,6 @@ implementation
****************************************************************************}
target_infos : array[ttarget] of ttargetinfo = (
{$ifdef i386}
(
target : target_GO32V1;
short_name : 'GO32V1';
@ -516,7 +550,8 @@ implementation
exeext : ''; { The linker procedures a.out }
os : os_GO32V1;
link : link_ldgo32v1;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_GO32V2;
@ -540,7 +575,8 @@ implementation
{$endif UseAnsiString}
os : os_GO32V2;
link : link_ldgo32v2;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_LINUX;
@ -555,7 +591,8 @@ implementation
exeext : '';
os : os_Linux;
link : link_ld;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_OS2;
@ -570,7 +607,8 @@ implementation
exeext : ''; { The linker procedures a.out }
os : os_OS2;
link : link_ldos2;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_WIN32;
@ -585,10 +623,10 @@ implementation
exeext : '.exe';
os : os_Win32;
link : link_ldw;
assem : as_asw
assem : as_asw;
ar : ar_arw
)
{$endif i386}
{$ifdef m68k}
(
target : target_Amiga;
@ -603,7 +641,8 @@ implementation
exeext : '';
os : os_Amiga;
link : link_ld;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_Atari;
@ -618,7 +657,8 @@ implementation
exeext : '';
os : os_Atari;
link : link_ld;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_Mac68k;
@ -633,7 +673,8 @@ implementation
exeext : '';
os : os_Mac68k;
link : link_ld;
assem : as_o
assem : as_o;
ar : ar_ar
),
(
target : target_Linux;
@ -648,7 +689,8 @@ implementation
exeext : '';
os : os_Linux;
link : link_ld;
assem : as_o
assem : as_o;
ar : ar_ar
)
{$endif m68k}
);
@ -689,6 +731,7 @@ begin
target_os:=os_infos[target_info.os];
target_asm:=as_infos[target_info.assem];
target_link:=link_infos[target_info.link];
target_ar:=ar_infos[target_info.ar];
end;
@ -757,19 +800,15 @@ begin
{$ifdef GO32V2}
default_os(target_GO32V2);
{$else}
{$ifdef OS2}
default_os(target_OS2);
{$else}
{$ifdef LINUX}
default_os(target_LINUX);
{$else}
{$ifdef WIN32}
default_os(target_WIN32);
{$else}
default_os(target_GO32V2);
{$endif win32}
{$endif linux}
@ -781,14 +820,12 @@ begin
{$ifdef AMIGA}
default_os(target_Amiga);
{$else}
{$ifdef ATARI}
default_os(target_Atari);
{$else}
{$ifdef MACOS}
default_os(target_MAC68k);
{$else}
default_os(target_Amiga);
{$endif macos}
{$endif atari}
@ -797,7 +834,11 @@ begin
end.
{
$Log$
Revision 1.17 1998-06-04 23:52:04 peter
Revision 1.18 1998-06-08 22:59:54 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.17 1998/06/04 23:52:04 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32

57
compiler/win_targ.pas
View File

@ -39,6 +39,9 @@ unit win_targ;
uses
aasm,files,strings,globals,cobjects
{$ifdef GDB}
,gdb
{$endif}
{$ifdef i386}
,i386
{$endif}
@ -83,42 +86,48 @@ unit win_targ;
hp2 : pimported_procedure;
l1,l2,l3,l4 : plabel;
r : preference;
begin
hp1:=pimportlist(current_module^.imports^.first);
while assigned(hp1) do
begin
{ Insert cuts for smartlinking }
if (cs_smartlink in aktswitches) then
begin
importssection^.concat(new(pai_cut,init));
codesegment^.concat(new(pai_cut,init));
end;
{$IfDef GDB}
if (cs_debuginfo in aktswitches) then
codesegment^.concat(new(pai_stab_function_name,init(nil)));
{$EndIf GDB}
{ Get labels for the sections }
getlabel(l1);
getlabel(l2);
getlabel(l3);
{ create import directory entry }
importssection^.concat(new(pai_section,init_idata(2)));
{ pointer to procedure names }
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
(l2)))));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l2)))));
{ two empty entries follow }
importssection^.concat(new(pai_const,init_32bit(0)));
importssection^.concat(new(pai_const,init_32bit(0)));
{ pointer to dll name }
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
(l1)))));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l1)))));
{ pointer to fixups }
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
(l3)))));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(l3)))));
{ now walk through all imported procedures }
{ we could that do in one while loop, but }
{ this would give too much idata* entries }
{ only create one section for each else it will
create a lot of idata* }
{ first write the name references }
importssection^.concat(new(pai_section,init_idata(4)));
importssection^.concat(new(pai_label,init(l2)));
hp2:=pimported_procedure(hp1^.imported_procedures^.first);
while assigned(hp2) do
begin
getlabel(plabel(hp2^.lab));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
(hp2^.lab)))));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(hp2^.lab)))));
hp2:=pimported_procedure(hp2^.next);
end;
{ finalize the names ... }
@ -130,20 +139,18 @@ unit win_targ;
hp2:=pimported_procedure(hp1^.imported_procedures^.first);
while assigned(hp2) do
begin
getlabel(l4);
{ text segment should be aligned }
codesegment^.concat(new(pai_align,init_op(4,$90)));
codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
{ the indirect jump }
getdatalabel(l4);
{ create indirect jump }
new(r);
reset_reference(r^);
r^.symbol:=stringdup(lab2str(l4));
{$ifdef i386}
{ place jump in codesegment }
codesegment^.concat(new(pai_align,init_op(4,$90)));
codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
codesegment^.concat(new(pai386,op_ref(A_JMP,S_NO,r)));
{$endif}
{ add jump field to importsection }
importssection^.concat(new(pai_label,init(l4)));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
(hp2^.lab)))));
importssection^.concat(new(pai_const,init_rva(strpnew(lab2str(hp2^.lab)))));
hp2:=pimported_procedure(hp2^.next);
end;
{ finalize the addresses }
@ -172,7 +179,11 @@ unit win_targ;
end.
{
$Log$
Revision 1.3 1998-06-04 23:52:06 peter
Revision 1.4 1998-06-08 22:59:56 peter
* smartlinking works for win32
* some defines to exclude some compiler parts
Revision 1.3 1998/06/04 23:52:06 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32