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

* tdicationary.replace added to replace and item in a dictionary. This

Browse Source 
is only allowed for the same name
  * varsyms are inserted in symtable before the types are parsed. This
    fixes the long standing "var longint : longint" bug
  - consume_idlist and idstringlist removed. The loops are inserted
    at the callers place and uses the symtable for duplicate id checking
This commit is contained in:
peter 2002-09-09 17:34:14 +00:00
parent c77737a105
commit a540ff122c
17 changed files with 589 additions and 469 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
compiler/cclasses.pas
View File

@ -196,7 +196,6 @@ interface
procedure inserttree(currtree,currroot:TNamedIndexItem);
public
noclear : boolean;
replace_existing : boolean;
delete_doubles : boolean;
constructor Create;
destructor Destroy;override;
@ -207,6 +206,7 @@ interface
procedure foreach(proc2call:TNamedIndexcallback;arg:pointer);
procedure foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
function insert(obj:TNamedIndexItem):TNamedIndexItem;
function replace(oldobj,newobj:TNamedIndexItem):boolean;
function rename(const olds,News : string):TNamedIndexItem;
function search(const s:string):TNamedIndexItem;
function speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
@ -237,6 +237,7 @@ interface
procedure deleteindex(p:TNamedIndexItem);
procedure delete(var p:TNamedIndexItem);
procedure insert(p:TNamedIndexItem);
procedure replace(oldp,newp:TNamedIndexItem);
function search(nr:integer):TNamedIndexItem;
private
growsize,
@ -844,7 +845,6 @@ end;
FRoot:=nil;
FHashArray:=nil;
noclear:=false;
replace_existing:=false;
delete_doubles:=false;
end;
@ -1120,6 +1120,78 @@ end;
end;
function Tdictionary.replace(oldobj,newobj:TNamedIndexItem):boolean;
var
hp : TNamedIndexItem;
begin
hp:=nil;
Replace:=false;
newobj.FSpeedValue:=GetSpeedValue(newobj.FName^);
{ must be the same name and hash }
if (oldobj.FSpeedValue<>newobj.FSpeedValue) or
(oldobj.FName^<>newobj.FName^) then
exit;
{ copy tree info }
newobj.FLeft:=oldobj.FLeft;
newobj.FRight:=oldobj.FRight;
{ update treeroot }
if assigned(FHashArray) then
begin
hp:=FHashArray^[newobj.FSpeedValue mod hasharraysize];
if hp=oldobj then
begin
FHashArray^[newobj.FSpeedValue mod hasharraysize]:=newobj;
hp:=nil;
end;
end
else
begin
hp:=FRoot;
if hp=oldobj then
begin
FRoot:=newobj;
hp:=nil;
end;
end;
{ update parent entry }
while assigned(hp) do
begin
{ is the node to replace the left or right, then
update this node and stop }
if hp.FLeft=oldobj then
begin
hp.FLeft:=newobj;
break;
end;
if hp.FRight=oldobj then
begin
hp.FRight:=newobj;
break;
end;
{ First check SpeedValue, to allow a fast insert }
if hp.SpeedValue>oldobj.SpeedValue then
hp:=hp.FRight
else
if hp.SpeedValue<oldobj.SpeedValue then
hp:=hp.FLeft
else
begin
if (hp.FName^=oldobj.FName^) then
begin
{ this can never happend, return error }
exit;
end
else
if oldobj.FName^>hp.FName^ then
hp:=hp.FLeft
else
hp:=hp.FRight;
end;
end;
Replace:=true;
end;
function Tdictionary.insert(obj:TNamedIndexItem):TNamedIndexItem;
begin
obj.FSpeedValue:=GetSpeedValue(obj.FName^);
@ -1153,7 +1225,7 @@ end;
insertNode:=insertNode(NewNode,currNode.FLeft)
else
begin
if (replace_existing or delete_doubles) and
if (delete_doubles) and
assigned(currNode) then
begin
NewNode.FLeft:=currNode.FLeft;
@ -1515,6 +1587,27 @@ end;
end;
procedure tindexarray.replace(oldp,newp:TNamedIndexItem);
var
i : integer;
begin
newp.FIndexnr:=oldp.FIndexnr;
newp.FIndexNext:=oldp.FIndexNext;
data^[newp.FIndexnr]:=newp;
{ update Linked List backward }
i:=newp.FIndexnr;
while (i>0) do
begin
dec(i);
if (i>0) and assigned(data^[i]) then
begin
data^[i].FIndexNext:=newp;
break;
end;
end;
end;
{****************************************************************************
tdynamicarray
****************************************************************************}
@ -1751,7 +1844,15 @@ end;
end.
{
$Log$
Revision 1.18 2002-09-05 19:29:42 peter
Revision 1.19 2002-09-09 17:34:14 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.18 2002/09/05 19:29:42 peter
* memdebug enhancements
Revision 1.17 2002/08/11 13:24:11 peter

17
compiler/import.pas
View File

@ -28,7 +28,8 @@ interface
uses
cutils,cclasses,
systems,
aasmbase;
aasmbase,
symsym;
type
timported_item = class(TLinkedListItem)
@ -58,7 +59,7 @@ type
destructor Destroy;override;
procedure preparelib(const s:string);virtual;
procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
procedure importvariable(const varname,module:string;const name:string);virtual;
procedure importvariable(vs:tvarsym;const name,module:string);virtual;
procedure generatelib;virtual;
procedure generatesmartlib;virtual;
end;
@ -185,7 +186,7 @@ begin
end;
procedure timportlib.importvariable(const varname,module:string;const name:string);
procedure timportlib.importvariable(vs:tvarsym;const name,module:string);
begin
NotSupported;
end;
@ -237,7 +238,15 @@ end;
end.
{
$Log$
Revision 1.19 2002-07-26 21:15:38 florian
Revision 1.20 2002-09-09 17:34:14 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.19 2002/07/26 21:15:38 florian
* rewrote the system handling
Revision 1.18 2002/07/01 18:46:22 peter

139
compiler/pbase.pas
View File

@ -30,9 +30,6 @@ interface
cutils,cclasses,
tokens,globals,
symconst,symbase,symtype,symdef,symsym,symtable
{$ifdef fixLeaksOnError}
,comphook
{$endif fixLeaksOnError}
;
const
@ -42,21 +39,6 @@ interface
{ special for handling procedure vars }
getprocvardef : tprocvardef = nil;
type
{ listitem }
tidstringlistitem = class(tlinkedlistitem)
data : pstring;
file_info : tfileposinfo;
constructor Create(const s:string;const pos:tfileposinfo);
destructor Destroy;override;
end;
tidstringlist=class(tlinkedlist)
procedure add(const s : string;const file_info : tfileposinfo);
function get(var file_info : tfileposinfo) : string;
function find(const s:string):boolean;
end;
var
{ size of data segment, set by proc_unit or proc_program }
datasize : longint;
@ -73,12 +55,6 @@ interface
{ true, if we should ignore an equal in const x : 1..2=2 }
ignore_equal : boolean;
{$ifdef fixLeaksOnError}
{ not worth it to make a pstack, there's only one data field (a pointer). }
{ in the interface, because pmodules and psub also use it for their names }
var strContStack: TStack;
pbase_old_do_stop: tstopprocedure;
{$endif fixLeaksOnError}
procedure identifier_not_found(const s:string);
@ -99,8 +75,6 @@ interface
procedure consume_emptystats;
{ reads a list of identifiers into a string list }
function consume_idlist : tidstringlist;
{ consume a symbol, if not found give an error and
and return an errorsym }
function consume_sym(var srsym:tsym;var srsymtable:tsymtable):boolean;
@ -117,73 +91,6 @@ implementation
uses
globtype,scanner,systems,verbose;
{****************************************************************************
TIdStringlistItem
****************************************************************************}
constructor TIDStringlistItem.Create(const s:string;const pos:tfileposinfo);
begin
data:=stringdup(s);
file_info:=pos;
end;
destructor TIDStringlistItem.Destroy;
begin
stringdispose(data);
end;
{****************************************************************************
TIdStringlist
****************************************************************************}
procedure tidstringlist.add(const s : string; const file_info : tfileposinfo);
begin
if find(s) then
exit;
inherited concat(tidstringlistitem.create(s,file_info));
end;
function tidstringlist.get(var file_info : tfileposinfo) : string;
var
p : tidstringlistitem;
begin
p:=tidstringlistitem(inherited getfirst);
if p=nil then
begin
get:='';
file_info.fileindex:=0;
file_info.line:=0;
file_info.column:=0;
end
else
begin
get:=p.data^;
file_info:=p.file_info;
p.free;
end;
end;
function tidstringlist.find(const s:string):boolean;
var
newnode : tidstringlistitem;
begin
find:=false;
newnode:=tidstringlistitem(First);
while assigned(newnode) do
begin
if newnode.data^=s then
begin
find:=true;
exit;
end;
newnode:=tidstringlistitem(newnode.next);
end;
end;
{****************************************************************************
Token Parsing
****************************************************************************}
@ -258,20 +165,6 @@ implementation
end;
{ reads a list of identifiers into a string list }
function consume_idlist : tidstringlist;
var
sc : tIdstringlist;
begin
sc:=TIdStringlist.Create;
repeat
sc.add(orgpattern,akttokenpos);
consume(_ID);
until not try_to_consume(_COMMA);
consume_idlist:=sc;
end;
function consume_sym(var srsym:tsym;var srsymtable:tsymtable):boolean;
begin
{ first check for identifier }
@ -342,32 +235,18 @@ implementation
until false;
end;
{$ifdef fixLeaksOnError}
procedure pbase_do_stop;
var names: PStringlist;
begin
names := PStringlist(strContStack.pop);
while names <> nil do
begin
dispose(names,done);
names := PStringlist(strContStack.pop);
end;
strContStack.done;
do_stop := pbase_old_do_stop;
do_stop{$ifdef FPCPROCVAR}(){$endif};
end;
begin
strContStack.init;
pbase_old_do_stop := do_stop;
do_stop := {$ifdef FPCPROCVAR}(){$endif}pbase_do_stop;
{$endif fixLeaksOnError}
end.
{
$Log$
Revision 1.18 2002-08-17 09:23:38 florian
Revision 1.19 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.18 2002/08/17 09:23:38 florian
* first part of procinfo rewrite
Revision 1.17 2002/05/18 13:34:11 peter

69
compiler/pdecobj.pas
View File

@ -223,7 +223,6 @@ implementation
overriden : tsym;
hs : string;
varspez : tvarspez;
sc : tidstringlist;
s : string;
tt : ttype;
declarepos : tfileposinfo;
@ -231,6 +230,9 @@ implementation
pd : tprocdef;
pt : tnode;
propname : stringid;
dummyst : tparasymtable;
vs : tvarsym;
sc : tsinglelist;
begin
{ check for a class }
aktprocsym:=nil;
@ -253,6 +255,11 @@ implementation
Message(parser_e_cant_publish_that_property);
{ create a list of the parameters in propertyparas }
dummyst:=tparasymtable.create;
dummyst.next:=symtablestack;
symtablestack:=dummyst;
sc:=tsinglelist.create;
consume(_LECKKLAMMER);
inc(testcurobject);
repeat
@ -271,24 +278,20 @@ implementation
consume(_OUT);
varspez:=vs_out;
end
else varspez:=vs_value;
sc:=consume_idlist;
{$ifdef fixLeaksOnError}
strContStack.push(sc);
{$endif fixLeaksOnError}
else
varspez:=vs_value;
sc.reset;
repeat
vs:=tvarsym.create(orgpattern,generrortype);
dummyst.insert(vs);
sc.insert(vs);
consume(_ID);
until not try_to_consume(_COMMA);
if token=_COLON then
begin
consume(_COLON);
if token=_ARRAY then
begin
{
if (varspez<>vs_const) and
(varspez<>vs_var) then
begin
varspez:=vs_const;
Message(parser_e_illegal_open_parameter);
end;
}
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
@ -301,24 +304,24 @@ implementation
end
else
tt:=cformaltype;
repeat
s:=sc.get(declarepos);
if s='' then
break;
hp2:=TParaItem.create;
hp2.paratyp:=varspez;
hp2.paratype:=tt;
propertyparas.insert(hp2);
until false;
{$ifdef fixLeaksOnError}
if strContStack.pop <> sc then
writeln('problem with strContStack in ptype');
{$endif fixLeaksOnError}
sc.free;
vs:=tvarsym(sc.first);
while assigned(vs) do
begin
hp2:=TParaItem.create;
hp2.paratyp:=varspez;
hp2.paratype:=tt;
propertyparas.insert(hp2);
vs:=tvarsym(vs.listnext);
end;
until not try_to_consume(_SEMICOLON);
dec(testcurobject);
consume(_RECKKLAMMER);
{ remove dummy symtable }
symtablestack:=symtablestack.next;
dummyst.free;
sc.free;
{ the parser need to know if a property has parameters, the
index parameter doesn't count (PFV) }
if not(propertyparas.empty) then
@ -1147,7 +1150,15 @@ implementation
end.
{
$Log$
Revision 1.50 2002-09-03 16:26:26 daniel
Revision 1.51 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.50 2002/09/03 16:26:26 daniel
* Make Tprocdef.defs protected
Revision 1.49 2002/08/17 09:23:38 florian

169
compiler/pdecsub.pas
View File

@ -102,10 +102,7 @@ implementation
}
var
is_procvar : boolean;
sc : tidstringlist;
s : string;
hpos,
storetokenpos : tfileposinfo;
sc : tsinglelist;
htype,
tt : ttype;
hvs,
@ -117,17 +114,37 @@ implementation
tdefaultvalue : tconstsym;
defaultrequired : boolean;
old_object_option : tsymoptions;
dummyst : tparasymtable;
currparast : tparasymtable;
begin
{ reset }
defaultrequired:=false;
{ parsing a proc or procvar ? }
is_procvar:=(aktprocdef.deftype=procvardef);
consume(_LKLAMMER);
{ Delphi/Kylix supports nonsense like }
{ procedure p(); }
if try_to_consume(_RKLAMMER) and
not(m_tp7 in aktmodeswitches) then
exit;
{ parsing a proc or procvar ? }
is_procvar:=(aktprocdef.deftype=procvardef);
{ create dummy symtable for procvars }
if is_procvar then
begin
{ we can't insert the dummyst in the symtablestack,
because definitions will be inserted in the symtablestack. And
this symtable is disposed at the end of the parsing, so the
definitions are lost }
dummyst:=tparasymtable.create;
currparast:=dummyst;
end
else
begin
{ parast is available, we can insert in symtablestack }
tprocdef(aktprocdef).parast.next:=symtablestack;
symtablestack:=tprocdef(aktprocdef).parast;
currparast:=tparasymtable(tprocdef(aktprocdef).parast);
end;
{ reset }
sc:=tsinglelist.create;
defaultrequired:=false;
{ the variables are always public }
old_object_option:=current_object_option;
current_object_option:=[sp_public];
@ -182,11 +199,14 @@ implementation
end
else
begin
{ read identifiers }
sc:=consume_idlist;
{$ifdef fixLeaksOnError}
strContStack.push(sc);
{$endif fixLeaksOnError}
{ read identifiers and insert with error type }
sc.reset;
repeat
vs:=tvarsym.create(orgpattern,generrortype);
currparast.insert(vs);
sc.insert(vs);
consume(_ID);
until not try_to_consume(_COMMA);
{ read type declaration, force reading for value and const paras }
if (token=_COLON) or (varspez=vs_value) then
begin
@ -237,17 +257,18 @@ implementation
{ everything else }
single_type(tt,hs1,false);
end;
{ default parameter }
if (m_default_para in aktmodeswitches) then
begin
if try_to_consume(_EQUAL) then
begin
s:=sc.get(hpos);
if not sc.empty then
Comment(V_Error,'default value only allowed for one parameter');
sc.add(s,hpos);
vs:=tvarsym(sc.first);
if assigned(vs) and
assigned(vs.listnext) then
Comment(V_Error,'default value only allowed for one parameter');
{ prefix 'def' to the parameter name }
tdefaultvalue:=ReadConstant('$def'+Upper(s),hpos);
tdefaultvalue:=ReadConstant('$def'+vs.name,vs.fileinfo);
if assigned(tdefaultvalue) then
tprocdef(aktprocdef).parast.insert(tdefaultvalue);
defaultrequired:=true;
@ -269,57 +290,59 @@ implementation
{$endif UseNiceNames}
tt:=cformaltype;
end;
storetokenpos:=akttokenpos;
while not sc.empty do
{ For proc vars we only need the definitions }
if not is_procvar then
begin
s:=sc.get(akttokenpos);
{ For proc vars we only need the definitions }
if not is_procvar then
vs:=tvarsym(sc.first);
while assigned(vs) do
begin
vs:=tvarsym.create(s,tt);
{ update varsym }
vs.vartype:=tt;
vs.varspez:=varspez;
{ we have to add this to avoid var param to be in registers !!!}
{ I don't understand the comment above, }
{ but I suppose the comment is wrong and }
{ it means that the address of var parameters can be placed }
{ in a register (FK) }
if (varspez in [vs_var,vs_const,vs_out]) and
paramanager.push_addr_param(tt.def,false) then
include(vs.varoptions,vo_regable);
{ insert the sym in the parasymtable }
tprocdef(aktprocdef).parast.insert(vs);
{ do we need a local copy? Then rename the varsym, do this after the
insert so the dup id checking is done correctly }
{ do we need a local copy? Then rename the varsym, do this after the
insert so the dup id checking is done correctly }
if (varspez=vs_value) and
paramanager.push_addr_param(tt.def,aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) and
not(is_open_array(tt.def) or is_array_of_const(tt.def)) then
tprocdef(aktprocdef).parast.rename(vs.name,'val'+vs.name);
currparast.rename(vs.name,'val'+vs.name);
{ also need to push a high value? }
{ also need to push a high value? }
if inserthigh then
begin
hvs:=tvarsym.create('$high'+Upper(s),s32bittype);
hvs:=tvarsym.create('$high'+vs.name,s32bittype);
hvs.varspez:=vs_const;
tprocdef(aktprocdef).parast.insert(hvs);
currparast.insert(hvs);
end;
end
else
vs:=nil;
aktprocdef.concatpara(tt,vs,varspez,tdefaultvalue);
aktprocdef.concatpara(tt,vs,varspez,tdefaultvalue);
vs:=tvarsym(vs.listnext);
end;
end
else
begin
vs:=tvarsym(sc.first);
while assigned(vs) do
begin
{ don't insert a parasym, the varsyms will be
disposed }
aktprocdef.concatpara(tt,nil,varspez,tdefaultvalue);
vs:=tvarsym(vs.listnext);
end;
end;
{$ifdef fixLeaksOnError}
if PStringContainer(strContStack.pop) <> sc then
writeln('problem with strContStack in pdecl (1)');
{$endif fixLeaksOnError}
sc.free;
akttokenpos:=storetokenpos;
end;
{ set the new mangled name }
until not try_to_consume(_SEMICOLON);
{ remove parasymtable from stack }
if is_procvar then
dummyst.free
else
symtablestack:=symtablestack.next;
sc.free;
{ reset object options }
dec(testcurobject);
current_object_option:=old_object_option;
consume(_RKLAMMER);
@ -703,19 +726,18 @@ implementation
single_type(aktprocdef.rettype,hs,false);
aktprocdef.test_if_fpu_result;
if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
((aktprocdef.rettype.def.deftype<>
orddef) or (torddef(aktprocdef.
rettype.def).typ<>bool8bit)) then
Message(parser_e_comparative_operator_return_boolean);
if assigned(otsym) then
otsym.vartype.def:=aktprocdef.rettype.def;
if (optoken=_ASSIGNMENT) and
is_equal(aktprocdef.rettype.def,
tvarsym(aktprocdef.parast.symindex.first).vartype.def) then
message(parser_e_no_such_assignment)
else if not isoperatoracceptable(aktprocdef,optoken) then
Message(parser_e_overload_impossible);
end;
((aktprocdef.rettype.def.deftype<>orddef) or
(torddef(aktprocdef.rettype.def).typ<>bool8bit)) then
Message(parser_e_comparative_operator_return_boolean);
if assigned(otsym) then
otsym.vartype.def:=aktprocdef.rettype.def;
if (optoken=_ASSIGNMENT) and
is_equal(aktprocdef.rettype.def,
tvarsym(aktprocdef.parast.symindex.first).vartype.def) then
message(parser_e_no_such_assignment)
else if not isoperatoracceptable(aktprocdef,optoken) then
Message(parser_e_overload_impossible);
end;
end;
end;
if isclassmethod and
@ -1396,6 +1418,12 @@ const
aktprocdef.proccalloption:=proc_direcdata[p].pocall;
end;
{ check if method and directive not for object, like public.
This needs to be checked also for procvars }
if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
(aktprocdef.owner.symtabletype=objectsymtable) then
exit;
if aktprocdef.deftype=procdef then
begin
{ Check if the directive is only for objects }
@ -1403,11 +1431,6 @@ const
not assigned(aktprocdef._class) then
exit;
{ check if method and directive not for object public }
if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
assigned(aktprocdef._class) then
exit;
{ check if method and directive not for interface }
if ((proc_direcdata[p].pd_flags and pd_notobjintf)<>0) and
is_interface(aktprocdef._class) then
@ -1976,7 +1999,15 @@ const
end.
{
$Log$
Revision 1.71 2002-09-07 15:25:06 peter
Revision 1.72 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.71 2002/09/07 15:25:06 peter
* old logs removed and tabs fixed
Revision 1.70 2002/09/03 16:26:27 daniel

332
compiler/pdecvar.pas
View File

@ -34,7 +34,7 @@ implementation
uses
{ common }
cutils,
cutils,cclasses,
{ global }
globtype,globals,tokens,verbose,
systems,
@ -62,46 +62,36 @@ implementation
{ => the procedure is also used to read }
{ a sequence of variable declaration }
procedure insert_syms(st : tsymtable;sc : tidstringlist;tt : ttype;is_threadvar : boolean);
procedure insert_syms(sc : tsinglelist;tt : ttype;is_threadvar : boolean);
{ inserts the symbols of sc in st with def as definition or sym as ttypesym, sc is disposed }
var
s : string;
filepos : tfileposinfo;
ss,ss2 : tvarsym;
vs,vs2 : tvarsym;
begin
filepos:=akttokenpos;
while not sc.empty do
vs:=tvarsym(sc.first);
while assigned(vs) do
begin
s:=sc.get(akttokenpos);
ss:=tvarsym.Create(s,tt);
vs.vartype:=tt;
if is_threadvar then
include(ss.varoptions,vo_is_thread_var);
st.insert(ss);
include(vs.varoptions,vo_is_thread_var);
{ static data fields are inserted in the globalsymtable }
if (st.symtabletype=objectsymtable) and
if (symtablestack.symtabletype=objectsymtable) and
(sp_static in current_object_option) then
begin
ss2:=tvarsym.create('$'+lower(st.name^)+'_'+upper(s),tt);
st.defowner.owner.insert(ss2);
st.defowner.owner.insertvardata(ss2);
vs2:=tvarsym.create('$'+lower(symtablestack.name^)+'_'+vs.name,tt);
symtablestack.defowner.owner.insert(vs2);
symtablestack.defowner.owner.insertvardata(vs2);
end
else
begin
{ external data is not possible here }
st.insertvardata(ss);
symtablestack.insertvardata(vs);
end;
vs:=tvarsym(vs.listnext);
end;
{$ifdef fixLeaksOnError}
if strContStack.pop <> sc then
writeln('problem with strContStack in pdecl (2)');
{$endif fixLeaksOnError}
sc.free;
akttokenpos:=filepos;
end;
var
sc : tidstringList;
s : stringid;
sc : tsinglelist;
old_block_type : tblock_type;
declarepos,storetokenpos : tfileposinfo;
oldsymtablestack : tsymtable;
@ -112,10 +102,9 @@ implementation
newtype : ttypesym;
is_dll,
is_gpc_name,is_cdecl,
extern_aktvarsym,export_aktvarsym : boolean;
extern_var,export_var : boolean;
old_current_object_option : tsymoptions;
dll_name,
C_name : string;
hs,sorg,C_name,dll_name : string;
tt,casetype : ttype;
{ Delphi initialized vars }
tconstsym : ttypedconstsym;
@ -124,6 +113,7 @@ implementation
usedalign,
maxsize,minalignment,maxalignment,startvarrecalign,startvarrecsize : longint;
pt : tnode;
vs : tvarsym;
srsym : tsym;
srsymtable : tsymtable;
unionsymtable : tsymtable;
@ -144,14 +134,18 @@ implementation
if not (token in [_ID,_CASE,_END]) then
consume(_ID);
{ read vars }
sc:=tsinglelist.create;
while (token=_ID) and
not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do
begin
C_name:=orgpattern;
sc:=consume_idlist;
{$ifdef fixLeaksOnError}
strContStack.push(sc);
{$endif fixLeaksOnError}
sorg:=orgpattern;
sc.reset;
repeat
vs:=tvarsym.create(orgpattern,generrortype);
symtablestack.insert(vs);
sc.insert(vs);
consume(_ID);
until not try_to_consume(_COMMA);
consume(_COLON);
if (m_gpc in aktmodeswitches) and
not(is_record or is_object or is_threadvar) and
@ -184,20 +178,13 @@ implementation
symdone:=false;
if is_gpc_name then
begin
storetokenpos:=akttokenpos;
s:=sc.get(akttokenpos);
if not sc.empty then
Message(parser_e_absolute_only_one_var);
{$ifdef fixLeaksOnError}
if strContStack.pop <> sc then
writeln('problem with strContStack in pdecl (3)');
{$endif fixLeaksOnError}
sc.free;
aktvarsym:=tvarsym.create_C(s,target_info.Cprefix+C_name,tt);
include(aktvarsym.varoptions,vo_is_external);
symtablestack.insert(aktvarsym);
{ external, so no insert in the data }
akttokenpos:=storetokenpos;
vs:=tvarsym(sc.first);
if assigned(vs.listnext) then
Message(parser_e_absolute_only_one_var);
vs.vartype:=tt;
include(vs.varoptions,vo_is_C_var);
vs.set_mangledname(target_info.Cprefix+sorg);
include(vs.varoptions,vo_is_external);
symdone:=true;
end;
{ check for absolute }
@ -206,106 +193,82 @@ implementation
begin
consume(_ABSOLUTE);
{ only allowed for one var }
s:=sc.get(declarepos);
if not sc.empty then
Message(parser_e_absolute_only_one_var);
{$ifdef fixLeaksOnError}
if strContStack.pop <> sc then
writeln('problem with strContStack in pdecl (4)');
{$endif fixLeaksOnError}
sc.free;
vs:=tvarsym(sc.first);
if assigned(vs.listnext) then
Message(parser_e_absolute_only_one_var);
{ parse the rest }
pt:=expr;
if (pt.nodetype=stringconstn) or (is_constcharnode(pt)) then
if (pt.nodetype=stringconstn) or
(is_constcharnode(pt)) then
begin
storetokenpos:=akttokenpos;
akttokenpos:=declarepos;
abssym:=tabsolutesym.create(s,tt);
abssym:=tabsolutesym.create(vs.realname,tt);
abssym.fileinfo:=vs.fileinfo;
if pt.nodetype=stringconstn then
s:=strpas(tstringconstnode(pt).value_str)
hs:=strpas(tstringconstnode(pt).value_str)
else
s:=chr(tordconstnode(pt).value);
hs:=chr(tordconstnode(pt).value);
consume(token);
abssym.abstyp:=toasm;
abssym.asmname:=stringdup(s);
symtablestack.insert(abssym);
akttokenpos:=storetokenpos;
symdone:=true;
end;
if not symdone then
abssym.asmname:=stringdup(hs);
{ replace the varsym }
symtablestack.replace(vs,abssym);
vs.free;
end
{ variable }
else if (pt.nodetype=loadn) then
begin
{ variable }
if (pt.nodetype=loadn) then
{ we should check the result type of srsym }
if not (tloadnode(pt).symtableentry.typ in [varsym,typedconstsym,funcretsym]) then
Message(parser_e_absolute_only_to_var_or_const);
abssym:=tabsolutesym.create(vs.realname,tt);
abssym.fileinfo:=vs.fileinfo;
abssym.abstyp:=tovar;
abssym.ref:=tstoredsym(tloadnode(pt).symtableentry);
symtablestack.replace(vs,abssym);
vs.free;
end
{ funcret }
else if (pt.nodetype=funcretn) then
begin
abssym:=tabsolutesym.create(vs.realname,tt);
abssym.fileinfo:=vs.fileinfo;
abssym.abstyp:=tovar;
abssym.ref:=tstoredsym(tfuncretnode(pt).funcretsym);
symtablestack.replace(vs,abssym);
vs.free;
end
{ address }
else if is_constintnode(pt) and
((target_info.system=system_i386_go32v2) or
(m_objfpc in aktmodeswitches) or
(m_delphi in aktmodeswitches)) then
begin
abssym:=tabsolutesym.create(vs.realname,tt);
abssym.fileinfo:=vs.fileinfo;
abssym.abstyp:=toaddr;
abssym.absseg:=false;
abssym.address:=tordconstnode(pt).value;
if (token=_COLON) and
(target_info.system=system_i386_go32v2) then
begin
{ we should check the result type of srsym }
if not (tloadnode(pt).symtableentry.typ in [varsym,typedconstsym,funcretsym]) then
Message(parser_e_absolute_only_to_var_or_const);
storetokenpos:=akttokenpos;
akttokenpos:=declarepos;
abssym:=tabsolutesym.create(s,tt);
abssym.abstyp:=tovar;
abssym.ref:=tstoredsym(tloadnode(pt).symtableentry);
symtablestack.insert(abssym);
akttokenpos:=storetokenpos;
symdone:=true;
end
{ funcret }
else if (pt.nodetype=funcretn) then
begin
storetokenpos:=akttokenpos;
akttokenpos:=declarepos;
abssym:=tabsolutesym.create(s,tt);
abssym.abstyp:=tovar;
abssym.ref:=tstoredsym(tfuncretnode(pt).funcretsym);
symtablestack.insert(abssym);
akttokenpos:=storetokenpos;
symdone:=true;
end;
{ address }
if (not symdone) then
begin
if is_constintnode(pt) and
((target_info.system=system_i386_go32v2) or
(m_objfpc in aktmodeswitches) or
(m_delphi in aktmodeswitches)) then
begin
storetokenpos:=akttokenpos;
akttokenpos:=declarepos;
abssym:=tabsolutesym.create(s,tt);
abssym.abstyp:=toaddr;
abssym.absseg:=false;
abssym.address:=tordconstnode(pt).value;
if (token=_COLON) and
(target_info.system=system_i386_go32v2) then
begin
consume(token);
pt.free;
pt:=expr;
if is_constintnode(pt) then
begin
abssym.address:=abssym.address shl 4+tordconstnode(pt).value;
abssym.absseg:=true;
end
else
Message(parser_e_absolute_only_to_var_or_const);
end;
symtablestack.insert(abssym);
akttokenpos:=storetokenpos;
symdone := true;
end
consume(token);
pt.free;
pt:=expr;
if is_constintnode(pt) then
begin
abssym.address:=abssym.address shl 4+tordconstnode(pt).value;
abssym.absseg:=true;
end
else
Message(parser_e_absolute_only_to_var_or_const);
end
Message(parser_e_absolute_only_to_var_or_const);
end;
symtablestack.replace(vs,abssym);
vs.free;
end
else
Message(parser_e_absolute_only_to_var_or_const);
if not symdone then
begin
tt := generrortype;
symtablestack.insert(tvarsym.create(s,tt));
symdone:=true;
end;
Message(parser_e_absolute_only_to_var_or_const);
pt.free;
symdone:=true;
end;
{ Handling of Delphi typed const = initialized vars ! }
{ When should this be rejected ?
@ -318,14 +281,14 @@ implementation
not is_record and
not is_object then
begin
storetokenpos:=akttokenpos;
s:=sc.get(akttokenpos);
if not sc.empty then
vs:=tvarsym(sc.first);
if assigned(vs.listnext) then
Message(parser_e_initialized_only_one_var);
tconstsym:=ttypedconstsym.createtype(s,tt,true);
symtablestack.insert(tconstsym);
tconstsym:=ttypedconstsym.createtype(vs.realname,tt,true);
tconstsym.fileinfo:=vs.fileinfo;
symtablestack.replace(vs,tconstsym);
vs.free;
symtablestack.insertconstdata(tconstsym);
akttokenpos:=storetokenpos;
consume(_EQUAL);
readtypedconst(tt,tconstsym,true);
symdone:=true;
@ -356,48 +319,46 @@ implementation
(idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then
begin
{ only allowed for one var }
s:=sc.get(declarepos);
if not sc.empty then
Message(parser_e_absolute_only_one_var);
{$ifdef fixLeaksOnError}
if strContStack.pop <> sc then
writeln('problem with strContStack in pdecl (5)');
{$endif fixLeaksOnError}
sc.free;
vs:=tvarsym(sc.first);
if assigned(vs.listnext) then
Message(parser_e_absolute_only_one_var);
{ set type of the var }
vs.vartype:=tt;
{ defaults }
is_dll:=false;
is_cdecl:=false;
extern_aktvarsym:=false;
export_aktvarsym:=false;
extern_var:=false;
export_var:=false;
C_name:=sorg;
{ cdecl }
if idtoken=_CVAR then
begin
consume(_CVAR);
consume(_SEMICOLON);
is_cdecl:=true;
C_name:=target_info.Cprefix+C_name;
C_name:=target_info.Cprefix+sorg;
end;
{ external }
if idtoken=_EXTERNAL then
begin
consume(_EXTERNAL);
extern_aktvarsym:=true;
extern_var:=true;
end;
{ export }
if idtoken in [_EXPORT,_PUBLIC] then
begin
consume(_ID);
if extern_aktvarsym or
if extern_var or
(symtablestack.symtabletype in [parasymtable,localsymtable]) then
Message(parser_e_not_external_and_export)
else
export_aktvarsym:=true;
export_var:=true;
end;
{ external and export need a name after when no cdecl is used }
if not is_cdecl then
begin
{ dll name ? }
if (extern_aktvarsym) and (idtoken<>_NAME) then
if (extern_var) and (idtoken<>_NAME) then
begin
is_dll:=true;
dll_name:=get_stringconst;
@ -406,32 +367,27 @@ implementation
C_name:=get_stringconst;
end;
{ consume the ; when export or external is used }
if extern_aktvarsym or export_aktvarsym then
if extern_var or export_var then
consume(_SEMICOLON);
{ insert in the symtable }
storetokenpos:=akttokenpos;
akttokenpos:=declarepos;
if is_dll then
aktvarsym:=tvarsym.create_dll(s,tt)
else
aktvarsym:=tvarsym.create_C(s,C_name,tt);
{ set some vars options }
if export_aktvarsym then
if is_dll then
include(vs.varoptions,vo_is_dll_var)
else
include(vs.varoptions,vo_is_C_var);
vs.set_mangledname(C_Name);
if export_var then
begin
inc(aktvarsym.refs);
include(aktvarsym.varoptions,vo_is_exported);
inc(vs.refs);
include(vs.varoptions,vo_is_exported);
end;
if extern_aktvarsym then
include(aktvarsym.varoptions,vo_is_external);
{ insert in the symtable }
symtablestack.insert(aktvarsym);
if extern_var then
include(vs.varoptions,vo_is_external);
{ insert in the datasegment when it is not external }
if not extern_aktvarsym then
symtablestack.insertvardata(aktvarsym);
akttokenpos:=storetokenpos;
if not extern_var then
symtablestack.insertvardata(vs);
{ now we can insert it in the import lib if its a dll, or
add it to the externals }
if extern_aktvarsym then
if extern_var then
begin
if is_dll then
begin
@ -440,11 +396,11 @@ implementation
current_module.uses_imports:=true;
importlib.preparelib(current_module.modulename^);
end;
importlib.importvariable(aktvarsym.mangledname,dll_name,C_name)
importlib.importvariable(vs,C_name,dll_name);
end
else
if target_info.DllScanSupported then
current_module.Externals.insert(tExternalsItem.create(aktvarsym.mangledname));
current_module.Externals.insert(tExternalsItem.create(vs.mangledname));
end;
symdone:=true;
end
@ -452,7 +408,7 @@ implementation
if (is_object) and (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then
begin
include(current_object_option,sp_static);
insert_syms(symtablestack,sc,tt,false);
insert_syms(sc,tt,false);
exclude(current_object_option,sp_static);
consume(_STATIC);
consume(_SEMICOLON);
@ -476,7 +432,7 @@ implementation
Message(parser_e_only_publishable_classes_can__be_published);
exclude(current_object_option,sp_published);
end;
insert_syms(symtablestack,sc,tt,is_threadvar);
insert_syms(sc,tt,is_threadvar);
current_object_option:=old_current_object_option;
end;
end;
@ -486,8 +442,9 @@ implementation
maxsize:=0;
maxalignment:=0;
consume(_CASE);
s:=pattern;
searchsym(s,srsym,srsymtable);
sorg:=orgpattern;
hs:=pattern;
searchsym(hs,srsym,srsymtable);
{ may be only a type: }
if assigned(srsym) and (srsym.typ in [typesym,unitsym]) then
begin
@ -508,9 +465,9 @@ implementation
symtablestack:=symtablestack.next;
read_type(casetype,'');
symtablestack:=oldsymtablestack;
aktvarsym:=tvarsym.create(s,casetype);
symtablestack.insert(aktvarsym);
symtablestack.insertvardata(aktvarsym);
vs:=tvarsym.create(sorg,casetype);
symtablestack.insert(vs);
symtablestack.insertvardata(vs);
end;
if not(is_ordinal(casetype.def)) or is_64bitint(casetype.def) then
Message(type_e_ordinal_expr_expected);
@ -519,6 +476,7 @@ implementation
Unionsymtable.next:=symtablestack;
registerdef:=false;
UnionDef:=trecorddef.create(unionsymtable);
uniondef.isunion:=true;
registerdef:=true;
symtablestack:=UnionSymtable;
startvarrecsize:=symtablestack.datasize;
@ -597,7 +555,15 @@ implementation
end.
{
$Log$
Revision 1.31 2002-08-25 19:25:20 peter
Revision 1.32 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.31 2002/08/25 19:25:20 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be

14
compiler/pmodules.pas
View File

@ -1185,7 +1185,9 @@ implementation
if token=_LKLAMMER then
begin
consume(_LKLAMMER);
consume_idlist;
repeat
consume(_ID);
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
end;
consume(_SEMICOLON);
@ -1386,7 +1388,15 @@ implementation
end.
{
$Log$
Revision 1.78 2002-09-07 15:25:07 peter
Revision 1.79 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.78 2002/09/07 15:25:07 peter
* old logs removed and tabs fixed
Revision 1.77 2002/09/03 16:26:27 daniel

24
compiler/symbase.pas
View File

@ -116,6 +116,7 @@ interface
procedure foreach(proc2call : tnamedindexcallback;arg:pointer);
procedure foreach_static(proc2call : tnamedindexstaticcallback;arg:pointer);
procedure insert(sym : tsymentry);virtual;
procedure replace(oldsym,newsym:tsymentry);
procedure insertvardata(sym : tsymentry);virtual;abstract;
procedure insertconstdata(sym : tsymentry);virtual;abstract;
function search(const s : stringid) : tsymentry;
@ -242,6 +243,19 @@ implementation
end;
procedure tsymtable.replace(oldsym,newsym:tsymentry);
begin
{ Replace the entry in the dictionary, this checks
the name }
if not symsearch.replace(oldsym,newsym) then
internalerror(200209061);
{ replace in index }
symindex.replace(oldsym,newsym);
{ set owner of new symb }
newsym.owner:=self;
end;
function tsymtable.search(const s : stringid) : tsymentry;
begin
search:=speedsearch(s,getspeedvalue(s));
@ -309,7 +323,15 @@ implementation
end.
{
$Log$
Revision 1.7 2002-08-25 19:25:20 peter
Revision 1.8 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.7 2002/08/25 19:25:20 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be

14
compiler/symdef.pas
View File

@ -208,6 +208,7 @@ interface
trecorddef = class(tabstractrecorddef)
public
isunion : boolean;
constructor create(p : tsymtable);
constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override;
@ -2904,6 +2905,7 @@ implementation
symtable.dataalignment:=1
else
symtable.dataalignment:=aktalignment.recordalignmax;
isunion:=false;
end;
@ -2920,6 +2922,7 @@ implementation
trecordsymtable(symtable).ppuload(ppufile);
read_member:=oldread_member;
symtable.defowner:=self;
isunion:=false;
end;
@ -2930,6 +2933,7 @@ implementation
inherited destroy;
end;
function trecorddef.needs_inittable : boolean;
begin
needs_inittable:=trecordsymtable(symtable).needs_init_final
@ -5537,7 +5541,15 @@ implementation
end.
{
$Log$
Revision 1.93 2002-09-07 15:25:07 peter
Revision 1.94 2002-09-09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.93 2002/09/07 15:25:07 peter
* old logs removed and tabs fixed
Revision 1.92 2002/09/05 19:29:42 peter

17
compiler/symsym.pas
View File

@ -355,10 +355,6 @@ interface
currently called procedure,
only set/unset in ncal }
aktvarsym : tvarsym; { pointer to the symbol for the
currently read var, only used
for variable directives }
generrorsym : tsym;
otsym : tvarsym;
@ -1102,7 +1098,7 @@ implementation
function Tprocsym.search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef;
matchtype:Tdefmatch; var pd : pprocdeflist):Tprocdef;
var
var
convtyp:tconverttype;
a,b:boolean;
oldpd : pprocdeflist;
@ -1578,7 +1574,6 @@ implementation
constructor tvarsym.create_C(const n,mangled : string;const tt : ttype);
begin
tvarsym(self).create(n,tt);
include(varoptions,vo_is_C_var);
stringdispose(_mangledname);
_mangledname:=stringdup(mangled);
end;
@ -2500,7 +2495,15 @@ implementation
end.
{
$Log$
Revision 1.64 2002-09-08 11:10:17 carl
Revision 1.65 2002-09-09 17:34:16 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.64 2002/09/08 11:10:17 carl
* bugfix 2109 (bad imho, but only way)
Revision 1.63 2002/09/07 18:17:41 florian

31
compiler/symtable.pas
View File

@ -1389,14 +1389,15 @@ implementation
hsym : tsym;
begin
{ check for duplicate id in para symtable of methods }
if assigned(procinfo._class) and
{ but not in nested procedures !}
if assigned(procinfo) and
assigned(procinfo._class) and
{ but not in nested procedures !}
(not(assigned(procinfo.parent)) or
(assigned(procinfo.parent) and
not(assigned(procinfo.parent._class)))
) and
{ funcretsym is allowed !! }
(sym.typ<>funcretsym) then
{ funcretsym is allowed !! }
(sym.typ<>funcretsym) then
begin
hsym:=search_class_member(procinfo._class,sym.name);
{ private ids can be reused }
@ -1906,9 +1907,17 @@ implementation
findunitsymtable:=st;
break;
end;
objectsymtable,
recordsymtable :
objectsymtable :
st:=st.defowner.owner;
recordsymtable :
begin
{ don't continue when the current
symtable is used for variant records }
if trecorddef(st.defowner).isunion then
st:=nil
else
st:=st.defowner.owner;
end;
else
internalerror(5566562);
end;
@ -2299,7 +2308,15 @@ implementation
end.
{
$Log$
Revision 1.70 2002-09-05 19:29:45 peter
Revision 1.71 2002-09-09 17:34:16 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.70 2002/09/05 19:29:45 peter
* memdebug enhancements
Revision 1.69 2002/08/25 19:25:21 peter

21
compiler/systems/t_beos.pas
View File

@ -28,13 +28,14 @@ unit t_beos;
interface
uses
symsym,
import,export,link;
type
timportlibbeos=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
end;
@ -63,7 +64,7 @@ implementation
cutils,cclasses,
verbose,systems,globtype,globals,
symconst,script,
fmodule,aasmbase,aasmtai,aasmcpu,cpubase,symsym,i_beos;
fmodule,aasmbase,aasmtai,aasmcpu,cpubase,i_beos;
{*****************************************************************************
TIMPORTLIBBEOS
@ -86,13 +87,13 @@ begin
end;
procedure timportlibbeos.importvariable(const varname,module:string;const name:string);
procedure timportlibbeos.importvariable(vs:tvarsym;const name,module:string);
begin
{ insert sharedlibrary }
current_module.linkothersharedlibs.add(SplitName(module),link_allways);
{ reset the mangledname and turn off the dll_var option }
aktvarsym.set_mangledname(name);
exclude(aktvarsym.varoptions,vo_is_dll_var);
vs.set_mangledname(name);
exclude(vs.varoptions,vo_is_dll_var);
end;
@ -465,7 +466,15 @@ initialization
end.
{
$Log$
Revision 1.1 2002-09-06 15:03:51 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:51 carl
* moved files to systems directory
Revision 1.24 2002/09/03 16:26:28 daniel

18
compiler/systems/t_fbsd.pas
View File

@ -42,7 +42,7 @@ implementation
timportlibfreebsd=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
end;
@ -88,13 +88,13 @@ begin
end;
procedure timportlibfreebsd.importvariable(const varname,module:string;const name:string);
procedure timportlibfreebsd.importvariable(vs:tvarsym;const name,module:string);
begin
{ insert sharedlibrary }
current_module.linkothersharedlibs.add(SplitName(module),link_allways);
{ reset the mangledname and turn off the dll_var option }
aktvarsym.set_mangledname(name);
exclude(aktvarsym.varoptions,vo_is_dll_var);
vs.set_mangledname(name);
exclude(vs.varoptions,vo_is_dll_var);
end;
@ -514,7 +514,15 @@ initialization
end.
{
$Log$
Revision 1.1 2002-09-06 15:03:51 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:51 carl
* moved files to systems directory
Revision 1.29 2002/09/03 16:26:28 daniel

21
compiler/systems/t_linux.pas
View File

@ -28,13 +28,14 @@ unit t_linux;
interface
uses
symsym,
import,export,link;
type
timportliblinux=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
end;
@ -64,7 +65,7 @@ implementation
cutils,cclasses,
verbose,systems,globtype,globals,
symconst,script,
fmodule,symsym
fmodule
{$ifdef i386}
,aasmbase,aasmtai,aasmcpu,cpubase
{$endif i386}
@ -95,13 +96,13 @@ begin
end;
procedure timportliblinux.importvariable(const varname,module:string;const name:string);
procedure timportliblinux.importvariable(vs:tvarsym;const name,module:string);
begin
{ insert sharedlibrary }
current_module.linkothersharedlibs.add(SplitName(module),link_allways);
{ reset the mangledname and turn off the dll_var option }
aktvarsym.set_mangledname(name);
exclude(aktvarsym.varoptions,vo_is_dll_var);
vs.set_mangledname(name);
exclude(vs.varoptions,vo_is_dll_var);
end;
@ -524,7 +525,15 @@ end.
{
$Log$
Revision 1.1 2002-09-06 15:03:51 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:51 carl
* moved files to systems directory
Revision 1.33 2002/09/03 16:26:28 daniel

18
compiler/systems/t_nwm.pas
View File

@ -102,7 +102,7 @@ implementation
timportlibnetware=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
end;
@ -147,13 +147,13 @@ begin
end;
procedure timportlibnetware.importvariable(const varname,module:string;const name:string);
procedure timportlibnetware.importvariable(vs:tvarsym;const name,module:string);
begin
{ insert sharedlibrary }
current_module.linkothersharedlibs.add(SplitName(module),link_allways);
{ reset the mangledname and turn off the dll_var option }
aktvarsym.set_mangledname(name);
exclude(aktvarsym.varoptions,vo_is_dll_var);
vs.set_mangledname(name);
exclude(vs.varoptions,vo_is_dll_var);
end;
@ -484,7 +484,15 @@ initialization
end.
{
$Log$
Revision 1.1 2002-09-06 15:03:50 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:50 carl
* moved files to systems directory
Revision 1.30 2002/09/03 16:26:29 daniel

18
compiler/systems/t_sunos.pas
View File

@ -45,7 +45,7 @@ implementation
timportlibsunos=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
end;
@ -96,13 +96,13 @@ begin
end;
procedure timportlibsunos.importvariable(const varname,module:string;const name:string);
procedure timportlibsunos.importvariable(vs:tvarsym;const name,module:string);
begin
{ insert sharedlibrary }
current_module.linkothersharedlibs.add(SplitName(module),link_allways);
{ reset the mangledname and turn off the dll_var option }
aktvarsym.set_mangledname(name);
exclude(aktvarsym.varoptions,vo_is_dll_var);
vs.set_mangledname(name);
exclude(vs.varoptions,vo_is_dll_var);
end;
@ -486,7 +486,15 @@ initialization
end.
{
$Log$
Revision 1.1 2002-09-06 15:03:50 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:50 carl
* moved files to systems directory
Revision 1.29 2002/09/03 16:26:29 daniel

27
compiler/systems/t_win32.pas
View File

@ -50,10 +50,13 @@ interface
pStr4=^tStr4;
timportlibwin32=class(timportlib)
private
procedure importvariable_str(const s:string;const name,module:string);
public
procedure GetDefExt(var N:longint;var P:pStr4);virtual;
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure importvariable(const varname,module:string;const name:string);override;
procedure importvariable(vs:tvarsym;const name,module:string);override;
procedure generatelib;override;
procedure generatenasmlib;virtual;
procedure generatesmartlib;override;
@ -171,7 +174,13 @@ const
end;
procedure timportlibwin32.importvariable(const varname,module:string;const name:string);
procedure timportlibwin32.importvariable(vs:tvarsym;const name,module:string);
begin
importvariable_str(vs.mangledname,name,module);
end;
procedure timportlibwin32.importvariable_str(const s:string;const name,module:string);
var
hp1 : timportlist;
hp2 : timported_item;
@ -194,7 +203,7 @@ const
hp1:=timportlist.create(hs);
current_module.imports.concat(hp1);
end;
hp2:=timported_item.create_var(varname,name);
hp2:=timported_item.create_var(s,name);
hp1.imported_items.concat(hp2);
end;
@ -1413,7 +1422,7 @@ function tDLLScannerWin32.GetEdata(HeaderEntry:cardinal):longbool;
importlib.preparelib(current_module.modulename^);
end;
if IsData then
importlib.importvariable(name,_n,name)
timportlibwin32(importlib).importvariable_str(name,_n,name)
else
importlib.importprocedure(name,_n,index,name);
end;
@ -1553,7 +1562,15 @@ initialization
end.
{
$Log$
Revision 1.1 2002-09-06 15:03:50 carl
Revision 1.2 2002-09-09 17:34:17 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.1 2002/09/06 15:03:50 carl
* moved files to systems directory
Revision 1.40 2002/09/03 16:26:29 daniel