123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475 |
- {
- $Id$
- Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
- This unit handles the symbol tables
- 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.
- ****************************************************************************
- }
- unit symtable;
- {$i defines.inc}
- interface
- uses
- { common }
- cutils,cobjects,
- { global }
- globtype,tokens,
- { symtable }
- symconst,symbase,symtype,symdef,symsym,
- { assembler }
- aasm
- ;
- {****************************************************************************
- Symtable types
- ****************************************************************************}
- type
- pstoredsymtable = ^tstoredsymtable;
- tstoredsymtable = object(tsymtable)
- constructor init(t : tsymtabletype);
- { load/write }
- constructor loadas(typ : tsymtabletype);
- procedure writeas;
- procedure loaddefs;
- procedure loadsyms;
- procedure writedefs;
- procedure writesyms;
- procedure prederef;
- procedure deref;
- procedure insert(sym : psymentry);virtual;
- procedure insert_in(psymt : psymtable;offset : longint);
- function speedsearch(const s : stringid;speedvalue : longint) : psymentry;virtual;
- procedure allsymbolsused;
- procedure allprivatesused;
- procedure allunitsused;
- procedure check_forwards;
- procedure checklabels;
- { change alignment for args only parasymtable }
- procedure set_alignment(_alignment : longint);
- {$ifdef CHAINPROCSYMS}
- procedure chainprocsyms;
- {$endif CHAINPROCSYMS}
- {$ifndef DONOTCHAINOPERATORS}
- procedure chainoperators;
- {$endif DONOTCHAINOPERATORS}
- procedure load_browser;
- procedure write_browser;
- {$ifdef GDB}
- procedure concatstabto(asmlist : taasmoutput);virtual;
- function getnewtypecount : word; virtual;
- {$endif GDB}
- end;
- punitsymtable = ^tunitsymtable;
- tunitsymtable = object(tstoredsymtable)
- unittypecount : word;
- unitsym : punitsym;
- {$ifdef GDB}
- dbx_count : longint;
- prev_dbx_counter : plongint;
- dbx_count_ok : boolean;
- is_stab_written : boolean;
- {$endif GDB}
- constructor init(t : tsymtabletype;const n : string);
- constructor loadasunit;
- destructor done;virtual;
- procedure writeasunit;
- {$ifdef GDB}
- procedure concattypestabto(asmlist : taasmoutput);
- function getnewtypecount : word; virtual;
- {$endif GDB}
- procedure load_symtable_refs;
- end;
- pwithsymtable = ^twithsymtable;
- twithsymtable = object(tsymtable)
- { used for withsymtable for allowing constructors }
- direct_with : boolean;
- { in fact it is a ptree }
- withnode : pointer;
- { ptree to load of direct with var }
- { already usable before firstwith
- needed for firstpass of function parameters PM }
- withrefnode : pointer;
- constructor init;
- destructor done;virtual;
- procedure clear;virtual;
- end;
- var
- constsymtable : psymtable; { symtable were the constants can be inserted }
- systemunit : punitsymtable; { pointer to the system unit }
- read_member : boolean; { reading members of an symtable }
- lexlevel : longint; { level of code }
- { 1 for main procedure }
- { 2 for normal function or proc }
- { higher for locals }
- {****************************************************************************
- Functions
- ****************************************************************************}
- {*** Misc ***}
- function globaldef(const s : string) : pdef;
- function findunitsymtable(st:psymtable):psymtable;
- procedure duplicatesym(sym:psym);
- procedure identifier_not_found(const s:string);
- {*** Search ***}
- function searchsym(const s : stringid;var srsym:psym;var srsymtable:psymtable):boolean;
- function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym;
- function searchsymonlyin(p : psymtable;const s : stringid):psym;
- function search_class_member(pd : pobjectdef;const s : string):psym;
- {*** PPU Write/Loading ***}
- procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
- procedure numberunits;
- procedure load_interface;
- {*** Object Helpers ***}
- function search_default_property(pd : pobjectdef) : ppropertysym;
- {*** symtable stack ***}
- procedure dellexlevel;
- procedure RestoreUnitSyms;
- {$ifdef DEBUG}
- procedure test_symtablestack;
- procedure list_symtablestack;
- {$endif DEBUG}
- {$ifdef UNITALIASES}
- type
- punit_alias = ^tunit_alias;
- tunit_alias = object(tnamedindexobject)
- newname : pstring;
- constructor init(const n:string);
- destructor done;virtual;
- end;
- var
- unitaliases : pdictionary;
- procedure addunitalias(const n:string);
- function getunitalias(const n:string):string;
- {$endif UNITALIASES}
- {*** Init / Done ***}
- procedure InitSymtable;
- procedure DoneSymtable;
- const
- { last operator which can be overloaded, the first_overloaded should
- be in tokens.pas after NOTOKEN }
- first_overloaded = _PLUS;
- last_overloaded = _ASSIGNMENT;
- type
- toverloaded_operators = array[NOTOKEN..last_overloaded] of pprocsym;
- var
- overloaded_operators : toverloaded_operators;
- { unequal is not equal}
- const
- overloaded_names : array [NOTOKEN..last_overloaded] of string[16] =
- ('error',
- 'plus','minus','star','slash','equal',
- 'greater','lower','greater_or_equal',
- 'lower_or_equal',
- 'sym_diff','starstar',
- 'as','is','in','or',
- 'and','div','mod','not','shl','shr','xor',
- 'assign');
- implementation
- uses
- { global }
- version,verbose,globals,
- { target }
- systems,
- { ppu }
- symppu,ppu,
- { module }
- finput,fmodule,
- {$ifdef GDB}
- gdb,
- {$endif GDB}
- { scanner }
- scanner,
- { codegen }
- hcodegen
- ;
- var
- in_loading : boolean; { remove !!! }
- {*****************************************************************************
- Symbol Call Back Functions
- *****************************************************************************}
- procedure write_refs(sym : pnamedindexobject);
- begin
- pstoredsym(sym)^.write_references;
- end;
- procedure check_forward(sym : pnamedindexobject);
- begin
- if psym(sym)^.typ=procsym then
- pprocsym(sym)^.check_forward
- { check also object method table }
- { we needn't to test the def list }
- { because each object has to have a type sym }
- else
- if (psym(sym)^.typ=typesym) and
- assigned(ptypesym(sym)^.restype.def) and
- (ptypesym(sym)^.restype.def^.deftype=objectdef) then
- pobjectdef(ptypesym(sym)^.restype.def)^.check_forwards;
- end;
- procedure labeldefined(p : pnamedindexobject);
- begin
- if (psym(p)^.typ=labelsym) and
- not(plabelsym(p)^.defined) then
- begin
- if plabelsym(p)^.used then
- Message1(sym_e_label_used_and_not_defined,plabelsym(p)^.realname)
- else
- Message1(sym_w_label_not_defined,plabelsym(p)^.realname);
- end;
- end;
- procedure unitsymbolused(p : pnamedindexobject);
- begin
- if (psym(p)^.typ=unitsym) and
- (punitsym(p)^.refs=0) and
- { do not claim for unit name itself !! }
- (punitsym(p)^.unitsymtable^.symtabletype=unitsymtable) then
- MessagePos2(psym(p)^.fileinfo,sym_n_unit_not_used,
- p^.name,current_module.modulename^);
- end;
- procedure varsymbolused(p : pnamedindexobject);
- begin
- if (psym(p)^.typ=varsym) and
- ((psym(p)^.owner^.symtabletype in
- [parasymtable,localsymtable,objectsymtable,staticsymtable])) then
- begin
- { unused symbol should be reported only if no }
- { error is reported }
- { if the symbol is in a register it is used }
- { also don't count the value parameters which have local copies }
- { also don't claim for high param of open parameters (PM) }
- if (Errorcount<>0) or
- (copy(p^.name,1,3)='val') or
- (copy(p^.name,1,4)='high') then
- exit;
- if (pvarsym(p)^.refs=0) then
- begin
- if (psym(p)^.owner^.symtabletype=parasymtable) or (vo_is_local_copy in pvarsym(p)^.varoptions) then
- begin
- MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_not_used,psym(p)^.realname);
- end
- else if (psym(p)^.owner^.symtabletype=objectsymtable) then
- MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_not_used,psym(p)^.owner^.name^,psym(p)^.realname)
- else
- MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_not_used,psym(p)^.realname);
- end
- else if pvarsym(p)^.varstate=vs_assigned then
- begin
- if (psym(p)^.owner^.symtabletype=parasymtable) then
- begin
- if not(pvarsym(p)^.varspez in [vs_var,vs_out]) then
- MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,psym(p)^.realname)
- end
- else if (vo_is_local_copy in pvarsym(p)^.varoptions) then
- begin
- if not(pvarsym(p)^.varspez in [vs_var,vs_out]) then
- MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,psym(p)^.realname);
- end
- else if (psym(p)^.owner^.symtabletype=objectsymtable) then
- MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_only_set,psym(p)^.owner^.name^,psym(p)^.realname)
- else if (psym(p)^.owner^.symtabletype<>parasymtable) then
- if not (vo_is_exported in pvarsym(p)^.varoptions) then
- MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_only_set,psym(p)^.realname);
- end;
- end
- else if ((psym(p)^.owner^.symtabletype in
- [objectsymtable,parasymtable,localsymtable,staticsymtable])) then
- begin
- if (Errorcount<>0) then
- exit;
- { do not claim for inherited private fields !! }
- if (pstoredsym(p)^.refs=0) and (psym(p)^.owner^.symtabletype=objectsymtable) then
- MessagePos2(psym(p)^.fileinfo,sym_n_private_method_not_used,psym(p)^.owner^.name^,psym(p)^.realname)
- { units references are problematic }
- else if (pstoredsym(p)^.refs=0) and not(psym(p)^.typ in [funcretsym,enumsym,unitsym]) then
- if (psym(p)^.typ<>procsym) or not (pprocsym(p)^.is_global) or
- { all program functions are declared global
- but unused should still be signaled PM }
- ((psym(p)^.owner^.symtabletype=staticsymtable) and
- not current_module.is_unit) then
- MessagePos2(psym(p)^.fileinfo,sym_h_local_symbol_not_used,SymTypeName[psym(p)^.typ],psym(p)^.realname);
- end;
- end;
- procedure TestPrivate(p : pnamedindexobject);
- begin
- if sp_private in psym(p)^.symoptions then
- varsymbolused(p);
- end;
- procedure objectprivatesymbolused(p : pnamedindexobject);
- begin
- {
- Don't test simple object aliases PM
- }
- if (psym(p)^.typ=typesym) and
- (ptypesym(p)^.restype.def^.deftype=objectdef) and
- (ptypesym(p)^.restype.def^.typesym=psym(p)) then
- pobjectdef(ptypesym(p)^.restype.def)^.symtable^.foreach(
- {$ifdef FPCPROCVAR}@{$endif}TestPrivate);
- end;
- {$ifdef GDB}
- var
- asmoutput : taasmoutput;
- procedure concatstab(p : pnamedindexobject);
- begin
- if psym(p)^.typ <> procsym then
- pstoredsym(p)^.concatstabto(asmoutput);
- end;
- procedure resetstab(p : pnamedindexobject);
- begin
- if psym(p)^.typ <> procsym then
- pstoredsym(p)^.isstabwritten:=false;
- end;
- procedure concattypestab(p : pnamedindexobject);
- begin
- if psym(p)^.typ = typesym then
- begin
- pstoredsym(p)^.isstabwritten:=false;
- pstoredsym(p)^.concatstabto(asmoutput);
- end;
- end;
- {$endif GDB}
- {$ifdef CHAINPROCSYMS}
- procedure chainprocsym(p : psym);
- var
- storesymtablestack : psymtable;
- srsym : psym;
- srsymtable : psymtable;
- begin
- if p^.typ=procsym then
- begin
- storesymtablestack:=symtablestack;
- symtablestack:=p^.owner^.next;
- while assigned(symtablestack) do
- begin
- { search for same procsym in other units }
- searchsym(p^.name,srsym,srsymtable)
- if assigned(srsym) and
- (srsym^.typ=procsym) then
- begin
- pprocsym(p)^.nextprocsym:=pprocsym(srsym);
- symtablestack:=storesymtablestack;
- exit;
- end
- else if srsym=nil then
- symtablestack:=nil
- else
- symtablestack:=srsymtable^.next;
- end;
- symtablestack:=storesymtablestack;
- end;
- end;
- {$endif}
- {****************************************************************************
- STORED SYMTABLE
- ****************************************************************************}
- constructor tstoredsymtable.init(t : tsymtabletype);
- begin
- symtabletype:=t;
- symtablelevel:=0;
- defowner:=nil;
- unitid:=0;
- next:=nil;
- name:=nil;
- address_fixup:=0;
- datasize:=0;
- if t=parasymtable then
- dataalignment:=4
- else
- dataalignment:=1;
- new(symindex,init(indexgrowsize));
- new(defindex,init(indexgrowsize));
- if symtabletype<>withsymtable then
- begin
- new(symsearch,init);
- symsearch^.noclear:=true;
- end
- else
- symsearch:=nil;
- end;
- {$ifndef DONOTCHAINOPERATORS}
- procedure tstoredsymtable.chainoperators;
- var
- p : pprocsym;
- t : ttoken;
- def : pprocdef;
- srsym : psym;
- srsymtable,
- storesymtablestack : psymtable;
- begin
- storesymtablestack:=symtablestack;
- symtablestack:=@self;
- make_ref:=false;
- for t:=first_overloaded to last_overloaded do
- begin
- p:=nil;
- def:=nil;
- overloaded_operators[t]:=nil;
- { each operator has a unique lowercased internal name PM }
- while assigned(symtablestack) do
- begin
- searchsym(overloaded_names[t],srsym,srsymtable);
- if not assigned(srsym) then
- begin
- if (t=_STARSTAR) then
- begin
- symtablestack:=systemunit;
- searchsym('POWER',srsym,srsymtable);
- end;
- end;
- if assigned(srsym) then
- begin
- if (srsym^.typ<>procsym) then
- internalerror(12344321);
- if assigned(p) then
- begin
- {$ifdef CHAINPROCSYMS}
- p^.nextprocsym:=pprocsym(srsym);
- {$endif CHAINPROCSYMS}
- def^.nextoverloaded:=pprocsym(srsym)^.definition;
- end
- else
- overloaded_operators[t]:=pprocsym(srsym);
- p:=pprocsym(srsym);
- def:=p^.definition;
- while assigned(def^.nextoverloaded) and
- (def^.nextoverloaded^.owner=p^.owner) do
- def:=def^.nextoverloaded;
- def^.nextoverloaded:=nil;
- symtablestack:=srsym^.owner^.next;
- end
- else
- begin
- symtablestack:=nil;
- {$ifdef CHAINPROCSYMS}
- if assigned(p) then
- p^.nextprocsym:=nil;
- {$endif CHAINPROCSYMS}
- end;
- { search for same procsym in other units }
- end;
- symtablestack:=@self;
- end;
- make_ref:=true;
- symtablestack:=storesymtablestack;
- end;
- {$endif DONOTCHAINOPERATORS}
- procedure tstoredsymtable.loaddefs;
- var
- hp : pdef;
- b : byte;
- begin
- { load start of definition section, which holds the amount of defs }
- if current_ppu^.readentry<>ibstartdefs then
- Message(unit_f_ppu_read_error);
- current_ppu^.getlongint;
- { read definitions }
- repeat
- b:=current_ppu^.readentry;
- case b of
- ibpointerdef : hp:=new(ppointerdef,load);
- ibarraydef : hp:=new(parraydef,load);
- iborddef : hp:=new(porddef,load);
- ibfloatdef : hp:=new(pfloatdef,load);
- ibprocdef : hp:=new(pprocdef,load);
- ibshortstringdef : hp:=new(pstringdef,shortload);
- iblongstringdef : hp:=new(pstringdef,longload);
- ibansistringdef : hp:=new(pstringdef,ansiload);
- ibwidestringdef : hp:=new(pstringdef,wideload);
- ibrecorddef : hp:=new(precorddef,load);
- ibobjectdef : hp:=new(pobjectdef,load);
- ibenumdef : hp:=new(penumdef,load);
- ibsetdef : hp:=new(psetdef,load);
- ibprocvardef : hp:=new(pprocvardef,load);
- ibfiledef : hp:=new(pfiledef,load);
- ibclassrefdef : hp:=new(pclassrefdef,load);
- ibformaldef : hp:=new(pformaldef,load);
- ibenddefs : break;
- ibend : Message(unit_f_ppu_read_error);
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- hp^.owner:=@self;
- defindex^.insert(hp);
- until false;
- end;
- procedure tstoredsymtable.loadsyms;
- var
- b : byte;
- sym : psym;
- begin
- { load start of definition section, which holds the amount of defs }
- if current_ppu^.readentry<>ibstartsyms then
- Message(unit_f_ppu_read_error);
- { skip amount of symbols, not used currently }
- current_ppu^.getlongint;
- { load datasize,dataalignment of this symboltable }
- datasize:=current_ppu^.getlongint;
- dataalignment:=current_ppu^.getlongint;
- { now read the symbols }
- repeat
- b:=current_ppu^.readentry;
- case b of
- ibtypesym : sym:=new(ptypesym,load);
- ibprocsym : sym:=new(pprocsym,load);
- ibconstsym : sym:=new(pconstsym,load);
- ibvarsym : sym:=new(pvarsym,load);
- ibfuncretsym : sym:=new(pfuncretsym,load);
- ibabsolutesym : sym:=new(pabsolutesym,load);
- ibenumsym : sym:=new(penumsym,load);
- ibtypedconstsym : sym:=new(ptypedconstsym,load);
- ibpropertysym : sym:=new(ppropertysym,load);
- ibunitsym : sym:=new(punitsym,load);
- iblabelsym : sym:=new(plabelsym,load);
- ibsyssym : sym:=new(psyssym,load);
- ibendsyms : break;
- ibend : Message(unit_f_ppu_read_error);
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- sym^.owner:=@self;
- symindex^.insert(sym);
- symsearch^.insert(sym);
- until false;
- end;
- procedure tstoredsymtable.writedefs;
- var
- pd : pstoreddef;
- begin
- { each definition get a number, write then the amount of defs to the
- ibstartdef entry }
- current_ppu^.putlongint(defindex^.count);
- current_ppu^.writeentry(ibstartdefs);
- { now write the definition }
- pd:=pstoreddef(defindex^.first);
- while assigned(pd) do
- begin
- pd^.write;
- pd:=pstoreddef(pd^.indexnext);
- end;
- { write end of definitions }
- current_ppu^.writeentry(ibenddefs);
- end;
- procedure tstoredsymtable.writesyms;
- var
- pd : pstoredsym;
- begin
- { each definition get a number, write then the amount of syms and the
- datasize to the ibsymdef entry }
- current_ppu^.putlongint(symindex^.count);
- current_ppu^.putlongint(datasize);
- current_ppu^.putlongint(dataalignment);
- current_ppu^.writeentry(ibstartsyms);
- { foreach is used to write all symbols }
- pd:=pstoredsym(symindex^.first);
- while assigned(pd) do
- begin
- pd^.write;
- pd:=pstoredsym(pd^.indexnext);
- end;
- { end of symbols }
- current_ppu^.writeentry(ibendsyms);
- end;
- {***********************************************
- Browser
- ***********************************************}
- procedure tstoredsymtable.load_browser;
- var
- b : byte;
- sym : pstoredsym;
- prdef : pstoreddef;
- oldrecsyms : psymtable;
- begin
- if symtabletype in [recordsymtable,objectsymtable] then
- begin
- oldrecsyms:=aktrecordsymtable;
- aktrecordsymtable:=@self;
- end;
- if symtabletype in [parasymtable,localsymtable] then
- begin
- oldrecsyms:=aktlocalsymtable;
- aktlocalsymtable:=@self;
- end;
- if symtabletype=staticppusymtable then
- aktstaticsymtable:=@self;
- b:=current_ppu^.readentry;
- if b <> ibbeginsymtablebrowser then
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- repeat
- b:=current_ppu^.readentry;
- case b of
- ibsymref : begin
- sym:=pstoredsym(readderef);
- resolvesym(sym);
- if assigned(sym) then
- sym^.load_references;
- end;
- ibdefref : begin
- prdef:=pstoreddef(readderef);
- resolvedef(prdef);
- if assigned(prdef) then
- begin
- if prdef^.deftype<>procdef then
- Message(unit_f_ppu_read_error);
- pprocdef(prdef)^.load_references;
- end;
- end;
- ibendsymtablebrowser : break;
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- until false;
- if symtabletype in [recordsymtable,objectsymtable] then
- aktrecordsymtable:=oldrecsyms;
- if symtabletype in [parasymtable,localsymtable] then
- aktlocalsymtable:=oldrecsyms;
- end;
- procedure tstoredsymtable.write_browser;
- var
- oldrecsyms : psymtable;
- begin
- { symbol numbering for references
- should have been done in write PM
- number_symbols;
- number_defs; }
- if symtabletype in [recordsymtable,objectsymtable] then
- begin
- oldrecsyms:=aktrecordsymtable;
- aktrecordsymtable:=@self;
- end;
- if symtabletype in [parasymtable,localsymtable] then
- begin
- oldrecsyms:=aktlocalsymtable;
- aktlocalsymtable:=@self;
- end;
- current_ppu^.writeentry(ibbeginsymtablebrowser);
- foreach({$ifdef FPCPROCVAR}@{$endif}write_refs);
- current_ppu^.writeentry(ibendsymtablebrowser);
- if symtabletype in [recordsymtable,objectsymtable] then
- aktrecordsymtable:=oldrecsyms;
- if symtabletype in [parasymtable,localsymtable] then
- aktlocalsymtable:=oldrecsyms;
- end;
- {$ifdef GDB}
- function tstoredsymtable.getnewtypecount : word;
- begin
- getnewtypecount:=pglobaltypecount^;
- inc(pglobaltypecount^);
- end;
- {$endif GDB}
- procedure order_overloads(p : Pnamedindexobject);
- begin
- if psym(p)^.typ=procsym then
- pprocsym(p)^.order_overloaded;
- end;
- procedure tstoredsymtable.prederef;
- var
- hs : psym;
- begin
- { first deref the ttypesyms }
- hs:=psym(symindex^.first);
- while assigned(hs) do
- begin
- hs^.prederef;
- hs:=psym(hs^.indexnext);
- end;
- end;
- procedure tstoredsymtable.deref;
- var
- hp : pdef;
- hs : psym;
- begin
- { deref the definitions }
- hp:=pdef(defindex^.first);
- while assigned(hp) do
- begin
- hp^.deref;
- hp:=pdef(hp^.indexnext);
- end;
- { deref the symbols }
- hs:=psym(symindex^.first);
- while assigned(hs) do
- begin
- hs^.deref;
- hs:=psym(hs^.indexnext);
- end;
- end;
- { this procedure is reserved for inserting case variant into
- a record symtable }
- { the offset is the location of the start of the variant
- and datasize and dataalignment corresponds to
- the complete size (see code in pdecl unit) PM }
- procedure tstoredsymtable.insert_in(psymt : psymtable;offset : longint);
- var
- ps,nps : pvarsym;
- pd,npd : pdef;
- storesize,storealign : longint;
- begin
- storesize:=psymt^.datasize;
- storealign:=psymt^.dataalignment;
- psymt^.datasize:=offset;
- ps:=pvarsym(symindex^.first);
- while assigned(ps) do
- begin
- { this is used to insert case variant into the main
- record }
- psymt^.datasize:=ps^.address+offset;
- nps:=pvarsym(ps^.indexnext);
- symindex^.deleteindex(ps);
- ps^.indexnext:=nil;
- ps^.left:=nil;
- ps^.right:=nil;
- psymt^.insert(ps);
- ps:=nps;
- end;
- pd:=pdef(defindex^.first);
- while assigned(pd) do
- begin
- npd:=pdef(pd^.indexnext);
- defindex^.deleteindex(pd);
- pd^.indexnext:=nil;
- pd^.left:=nil;
- pd^.right:=nil;
- psymt^.registerdef(pd);
- pd:=npd;
- end;
- psymt^.datasize:=storesize;
- psymt^.dataalignment:=storealign;
- end;
- constructor tstoredsymtable.loadas(typ : tsymtabletype);
- var
- storesymtable : psymtable;
- st_loading : boolean;
- begin
- st_loading:=in_loading;
- in_loading:=true;
- symtabletype:=typ;
- new(symindex,init(indexgrowsize));
- new(defindex,init(indexgrowsize));
- new(symsearch,init);
- symsearch^.noclear:=true;
- { reset }
- defowner:=nil;
- name:=nil;
- if typ=parasymtable then
- dataalignment:=4
- else
- dataalignment:=1;
- datasize:=0;
- address_fixup:= 0;
- unitid:=0;
- { setup symtabletype specific things }
- case typ of
- unitsymtable :
- begin
- symtablelevel:=0;
- {$ifndef NEWMAP}
- current_module.map^[0]:=@self;
- {$else NEWMAP}
- current_module.globalsymtable:=@self;
- {$endif NEWMAP}
- end;
- recordsymtable,
- objectsymtable :
- begin
- storesymtable:=aktrecordsymtable;
- aktrecordsymtable:=@self;
- end;
- parasymtable,
- localsymtable :
- begin
- storesymtable:=aktlocalsymtable;
- aktlocalsymtable:=@self;
- end;
- { used for local browser }
- staticppusymtable :
- begin
- aktstaticsymtable:=@self;
- symsearch^.usehash;
- end;
- end;
- { we need the correct symtable for registering }
- if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then
- begin
- next:=symtablestack;
- symtablestack:=@self;
- end;
- { load definitions }
- loaddefs;
- { load symbols }
- loadsyms;
- if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then
- begin
- { now we can deref the syms and defs }
- prederef;
- { restore symtablestack }
- symtablestack:=next;
- end;
- case typ of
- unitsymtable :
- begin
- {$ifdef NEWMAP}
- { necessary for dependencies }
- current_module.globalsymtable:=nil;
- {$endif NEWMAP}
- end;
- recordsymtable,
- objectsymtable :
- aktrecordsymtable:=storesymtable;
- localsymtable,
- parasymtable :
- aktlocalsymtable:=storesymtable;
- end;
- in_loading:=st_loading;
- end;
- procedure tstoredsymtable.writeas;
- var
- oldtyp : byte;
- storesymtable : psymtable;
- begin
- storesymtable:=aktrecordsymtable;
- case symtabletype of
- recordsymtable,
- objectsymtable :
- begin
- storesymtable:=aktrecordsymtable;
- aktrecordsymtable:=@self;
- oldtyp:=current_ppu^.entrytyp;
- current_ppu^.entrytyp:=subentryid;
- end;
- parasymtable,
- localsymtable :
- begin
- storesymtable:=aktlocalsymtable;
- aktlocalsymtable:=@self;
- end;
- end;
- { order procsym overloads }
- foreach({$ifdef FPCPROCVAR}@{$endif}Order_overloads);
- { write definitions }
- writedefs;
- { write symbols }
- writesyms;
- case symtabletype of
- recordsymtable,
- objectsymtable :
- begin
- current_ppu^.entrytyp:=oldtyp;
- aktrecordsymtable:=storesymtable;
- end;
- localsymtable,
- parasymtable :
- aktlocalsymtable:=storesymtable;
- end;
- end;
- procedure tstoredsymtable.insert(sym:psymentry);
- var
- hp : psymtable;
- hsym : psym;
- begin
- { set owner and sym indexnb }
- sym^.owner:=@self;
- {$ifdef CHAINPROCSYMS}
- { set the nextprocsym field }
- if sym^.typ=procsym then
- chainprocsym(sym);
- {$endif CHAINPROCSYMS}
- { writes the symbol in data segment if required }
- { also sets the datasize of owner }
- if not in_loading then
- pstoredsym(sym)^.insert_in_data;
- if (symtabletype in [staticsymtable,globalsymtable]) then
- begin
- hp:=symtablestack;
- while assigned(hp) do
- begin
- if hp^.symtabletype in [staticsymtable,globalsymtable] then
- begin
- hsym:=psym(hp^.search(sym^.name));
- if assigned(hsym) then
- DuplicateSym(hsym);
- end;
- hp:=hp^.next;
- end;
- end;
- { check the current symtable }
- hsym:=psym(search(sym^.name));
- if assigned(hsym) then
- begin
- { in TP and Delphi you can have a local with the
- same name as the function, the function is then hidden for
- the user. (Under delphi it can still be accessed using result),
- but don't allow hiding of RESULT }
- if (m_tp in aktmodeswitches) and
- (hsym^.typ=funcretsym) and
- not((m_result in aktmodeswitches) and
- (hsym^.name='RESULT')) then
- hsym^.owner^.rename(hsym^.name,'hidden'+hsym^.name)
- else
- begin
- DuplicateSym(hsym);
- exit;
- end;
- end;
- { check for duplicate id in local and parasymtable symtable }
- if (symtabletype=localsymtable) then
- { to be on the save side: }
- begin
- if assigned(next) and
- (next^.symtabletype=parasymtable) then
- begin
- hsym:=psym(next^.search(sym^.name));
- if assigned(hsym) then
- begin
- { a parameter and the function can have the same
- name in TP and Delphi, but RESULT not }
- if (m_tp in aktmodeswitches) and
- (sym^.typ=funcretsym) and
- not((m_result in aktmodeswitches) and
- (sym^.name='RESULT')) then
- sym^.setname('hidden'+sym^.name)
- else
- begin
- DuplicateSym(hsym);
- exit;
- end;
- end;
- end
- else if (current_module.flags and uf_local_browser)=0 then
- internalerror(43789);
- end;
- { check for duplicate id in local symtable of methods }
- if (symtabletype=localsymtable) and
- assigned(next) and
- assigned(next^.next) and
- { funcretsym is allowed !! }
- (sym^.typ <> funcretsym) and
- (next^.next^.symtabletype=objectsymtable) then
- begin
- hsym:=search_class_member(pobjectdef(next^.next^.defowner),sym^.name);
- if assigned(hsym) and
- { private ids can be reused }
- (not(sp_private in hsym^.symoptions) or
- (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
- begin
- { delphi allows to reuse the names in a class, but not
- in object (tp7 compatible) }
- if not((m_delphi in aktmodeswitches) and
- is_class(pdef(next^.next^.defowner))) then
- begin
- DuplicateSym(hsym);
- exit;
- end;
- end;
- end;
- { check for duplicate id in para symtable of methods }
- if (symtabletype=parasymtable) 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
- begin
- hsym:=search_class_member(procinfo^._class,sym^.name);
- if assigned(hsym) and
- { private ids can be reused }
- (not(sp_private in hsym^.symoptions) or
- (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
- begin
- { delphi allows to reuse the names in a class, but not
- in object (tp7 compatible) }
- if not((m_delphi in aktmodeswitches) and
- is_class(procinfo^._class)) then
- begin
- DuplicateSym(hsym);
- exit;
- end;
- end;
- end;
- { check for duplicate field id in inherited classes }
- if (sym^.typ=varsym) and
- (symtabletype=objectsymtable) and
- assigned(defowner) and
- (
- not(m_delphi in aktmodeswitches) or
- is_object(pdef(defowner))
- ) then
- begin
- { but private ids can be reused }
- hsym:=search_class_member(pobjectdef(defowner),sym^.name);
- if assigned(hsym) and
- (not(sp_private in hsym^.symoptions) or
- (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then
- begin
- DuplicateSym(hsym);
- exit;
- end;
- end;
- { register definition of typesym }
- if (sym^.typ = typesym) and
- assigned(ptypesym(sym)^.restype.def) then
- begin
- if not(assigned(ptypesym(sym)^.restype.def^.owner)) and
- (ptypesym(sym)^.restype.def^.deftype<>errordef) then
- registerdef(ptypesym(sym)^.restype.def);
- {$ifdef GDB}
- if (cs_debuginfo in aktmoduleswitches) and assigned(debuglist) and
- (symtabletype in [globalsymtable,staticsymtable]) then
- begin
- ptypesym(sym)^.isusedinstab := true;
- {sym^.concatstabto(debuglist);}
- end;
- {$endif GDB}
- end;
- { insert in index and search hash }
- symindex^.insert(sym);
- symsearch^.insert(sym);
- end;
- function tstoredsymtable.speedsearch(const s : stringid;speedvalue : longint) : psymentry;
- var
- hp : pstoredsym;
- newref : pref;
- begin
- hp:=pstoredsym(inherited speedsearch(s,speedvalue));
- if assigned(hp) then
- begin
- { reject non static members in static procedures,
- be carefull aktprocsym^.definition is not allways
- loaded already (PFV) }
- if (symtabletype=objectsymtable) and
- not(sp_static in hp^.symoptions) and
- allow_only_static
- {assigned(aktprocsym) and
- assigned(aktprocsym^.definition) and
- ((aktprocsym^.definition^.options and postaticmethod)<>0)} then
- Message(sym_e_only_static_in_static);
- if (symtabletype=unitsymtable) and
- assigned(punitsymtable(@self)^.unitsym) then
- inc(punitsymtable(@self)^.unitsym^.refs);
- {$ifdef GDB}
- { if it is a type, we need the stabs of this type
- this might be the cause of the class debug problems
- as TCHILDCLASS.Create did not generate appropriate
- stabs debug info if TCHILDCLASS wasn't used anywhere else PM }
- if (hp^.typ=typesym) and make_ref then
- begin
- if assigned(ptypesym(hp)^.restype.def) then
- pstoreddef(ptypesym(hp)^.restype.def)^.numberstring
- else
- ptypesym(hp)^.isusedinstab:=true;
- end;
- {$endif GDB}
- { unitsym are only loaded for browsing PM }
- { this was buggy anyway because we could use }
- { unitsyms from other units in _USES !! }
- {if (symtabletype=unitsymtable) and (hp^.typ=unitsym) and
- assigned(current_module) and (current_module.globalsymtable<>@self) then
- hp:=nil;}
- if assigned(hp) and
- (cs_browser in aktmoduleswitches) and make_ref then
- begin
- new(newref,init(hp^.lastref,@akttokenpos));
- { for symbols that are in tables without
- browser info or syssyms (PM) }
- if hp^.refcount=0 then
- begin
- hp^.defref:=newref;
- hp^.lastref:=newref;
- end
- else
- if resolving_forward and assigned(hp^.defref) then
- { put it as second reference }
- begin
- newref^.nextref:=hp^.defref^.nextref;
- hp^.defref^.nextref:=newref;
- hp^.lastref^.nextref:=nil;
- end
- else
- hp^.lastref:=newref;
- inc(hp^.refcount);
- end;
- if assigned(hp) and make_ref then
- begin
- inc(hp^.refs);
- end;
- end;
- speedsearch:=hp;
- end;
- {***********************************************
- Process all entries
- ***********************************************}
- { checks, if all procsyms and methods are defined }
- procedure tstoredsymtable.check_forwards;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}check_forward);
- end;
- procedure tstoredsymtable.checklabels;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}labeldefined);
- end;
- procedure tstoredsymtable.set_alignment(_alignment : longint);
- var
- sym : pvarsym;
- l : longint;
- begin
- dataalignment:=_alignment;
- if (symtabletype<>parasymtable) then
- internalerror(1111);
- sym:=pvarsym(symindex^.first);
- datasize:=0;
- { there can be only varsyms }
- while assigned(sym) do
- begin
- l:=sym^.getpushsize;
- sym^.address:=datasize;
- datasize:=align(datasize+l,dataalignment);
- sym:=pvarsym(sym^.indexnext);
- end;
- end;
- procedure tstoredsymtable.allunitsused;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}unitsymbolused);
- end;
- procedure tstoredsymtable.allsymbolsused;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}varsymbolused);
- end;
- procedure tstoredsymtable.allprivatesused;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}objectprivatesymbolused);
- end;
- {$ifdef CHAINPROCSYMS}
- procedure tstoredsymtable.chainprocsyms;
- begin
- foreach({$ifdef FPCPROCVAR}@{$endif}chainprocsym);
- end;
- {$endif CHAINPROCSYMS}
- {$ifdef GDB}
- procedure tstoredsymtable.concatstabto(asmlist : taasmoutput);
- begin
- asmoutput:=asmlist;
- if symtabletype in [inlineparasymtable,inlinelocalsymtable] then
- foreach({$ifdef FPCPROCVAR}@{$endif}resetstab);
- foreach({$ifdef FPCPROCVAR}@{$endif}concatstab);
- end;
- {$endif}
- {****************************************************************************
- TWITHSYMTABLE
- ****************************************************************************}
- constructor twithsymtable.init;
- begin
- inherited init(withsymtable);
- direct_with:=false;
- withnode:=nil;
- withrefnode:=nil;
- { we don't need the symsearch }
- dispose(symsearch,done);
- symsearch:=nil;
- end;
- destructor twithsymtable.done;
- begin
- symsearch:=nil;
- inherited done;
- end;
- procedure twithsymtable.clear;
- begin
- { remove no entry from a withsymtable as it is only a pointer to the
- recorddef or objectdef symtable }
- end;
- {****************************************************************************
- PPU Writing Helpers
- ****************************************************************************}
- procedure writesourcefiles;
- var
- hp : tinputfile;
- i,j : longint;
- begin
- { second write the used source files }
- current_ppu^.do_crc:=false;
- hp:=current_module.sourcefiles.files;
- { write source files directly in good order }
- j:=0;
- while assigned(hp) do
- begin
- inc(j);
- hp:=hp.ref_next;
- end;
- while j>0 do
- begin
- hp:=current_module.sourcefiles.files;
- for i:=1 to j-1 do
- hp:=hp.ref_next;
- current_ppu^.putstring(hp.name^);
- dec(j);
- end;
- current_ppu^.writeentry(ibsourcefiles);
- current_ppu^.do_crc:=true;
- end;
- procedure writeusedmacro(p:pnamedindexobject);
- begin
- if pmacro(p)^.is_used or pmacro(p)^.defined_at_startup then
- begin
- current_ppu^.putstring(p^.name);
- current_ppu^.putbyte(byte(pmacro(p)^.defined_at_startup));
- current_ppu^.putbyte(byte(pmacro(p)^.is_used));
- end;
- end;
- procedure writeusedmacros;
- begin
- current_ppu^.do_crc:=false;
- current_scanner^.macros^.foreach({$ifdef FPCPROCVAR}@{$endif}writeusedmacro);
- current_ppu^.writeentry(ibusedmacros);
- current_ppu^.do_crc:=true;
- end;
- procedure writeusedunit;
- var
- hp : tused_unit;
- begin
- numberunits;
- hp:=tused_unit(current_module.used_units.first);
- while assigned(hp) do
- begin
- { implementation units should not change
- the CRC PM }
- current_ppu^.do_crc:=hp.in_interface;
- current_ppu^.putstring(hp.name^);
- { the checksum should not affect the crc of this unit ! (PFV) }
- current_ppu^.do_crc:=false;
- current_ppu^.putlongint(hp.checksum);
- current_ppu^.putlongint(hp.interface_checksum);
- current_ppu^.putbyte(byte(hp.in_interface));
- current_ppu^.do_crc:=true;
- hp:=tused_unit(hp.next);
- end;
- current_ppu^.do_interface_crc:=true;
- current_ppu^.writeentry(ibloadunit);
- end;
- procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
- var
- hcontainer : tlinkcontainer;
- s : string;
- mask : longint;
- begin
- hcontainer:=TLinkContainer.Create;
- while not p.empty do
- begin
- s:=p.get(mask);
- if strippath then
- current_ppu^.putstring(SplitFileName(s))
- else
- current_ppu^.putstring(s);
- current_ppu^.putlongint(mask);
- hcontainer.add(s,mask);
- end;
- current_ppu^.writeentry(id);
- p.Free;
- p:=hcontainer;
- end;
- procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
- begin
- Message1(unit_u_ppu_write,s);
- { create unit flags }
- with Current_Module do
- begin
- {$ifdef GDB}
- if cs_gdb_dbx in aktglobalswitches then
- flags:=flags or uf_has_dbx;
- {$endif GDB}
- if target_os.endian=endian_big then
- flags:=flags or uf_big_endian;
- if cs_browser in aktmoduleswitches then
- flags:=flags or uf_has_browser;
- if cs_local_browser in aktmoduleswitches then
- flags:=flags or uf_local_browser;
- end;
- {$ifdef Test_Double_checksum_write}
- If only_crc then
- Assign(CRCFile,s+'.INT')
- else
- Assign(CRCFile,s+'.IMP');
- Rewrite(CRCFile);
- {$endif def Test_Double_checksum_write}
- { open ppufile }
- current_ppu:=new(pppufile,init(s));
- current_ppu^.crc_only:=only_crc;
- if not current_ppu^.create then
- Message(unit_f_ppu_cannot_write);
- {$ifdef Test_Double_checksum}
- if only_crc then
- begin
- new(current_ppu^.crc_test);
- new(current_ppu^.crc_test2);
- end
- else
- begin
- current_ppu^.crc_test:=current_module.crc_array;
- current_ppu^.crc_index:=current_module.crc_size;
- current_ppu^.crc_test2:=current_module.crc_array2;
- current_ppu^.crc_index2:=current_module.crc_size2;
- end;
- {$endif def Test_Double_checksum}
- current_ppu^.change_endian:=source_os.endian<>target_os.endian;
- { write symbols and definitions }
- unittable^.writeasunit;
- { flush to be sure }
- current_ppu^.flush;
- { create and write header }
- current_ppu^.header.size:=current_ppu^.size;
- current_ppu^.header.checksum:=current_ppu^.crc;
- current_ppu^.header.interface_checksum:=current_ppu^.interface_crc;
- current_ppu^.header.compiler:=wordversion;
- current_ppu^.header.cpu:=word(target_cpu);
- current_ppu^.header.target:=word(target_info.target);
- current_ppu^.header.flags:=current_module.flags;
- If not only_crc then
- current_ppu^.writeheader;
- { save crc in current_module also }
- current_module.crc:=current_ppu^.crc;
- current_module.interface_crc:=current_ppu^.interface_crc;
- if only_crc then
- begin
- {$ifdef Test_Double_checksum}
- current_module.crc_array:=current_ppu^.crc_test;
- current_ppu^.crc_test:=nil;
- current_module.crc_size:=current_ppu^.crc_index2;
- current_module.crc_array2:=current_ppu^.crc_test2;
- current_ppu^.crc_test2:=nil;
- current_module.crc_size2:=current_ppu^.crc_index2;
- {$endif def Test_Double_checksum}
- closecurrentppu;
- end;
- {$ifdef Test_Double_checksum_write}
- close(CRCFile);
- {$endif Test_Double_checksum_write}
- end;
- procedure readusedmacros;
- var
- hs : string;
- mac : pmacro;
- was_defined_at_startup,
- was_used : boolean;
- begin
- while not current_ppu^.endofentry do
- begin
- hs:=current_ppu^.getstring;
- was_defined_at_startup:=boolean(current_ppu^.getbyte);
- was_used:=boolean(current_ppu^.getbyte);
- mac:=pmacro(current_scanner^.macros^.search(hs));
- if assigned(mac) then
- begin
- {$ifndef EXTDEBUG}
- { if we don't have the sources why tell }
- if current_module.sources_avail then
- {$endif ndef EXTDEBUG}
- if (not was_defined_at_startup) and
- was_used and
- mac^.defined_at_startup then
- Message2(unit_h_cond_not_set_in_last_compile,hs,current_module.mainsource^);
- end
- else { not assigned }
- if was_defined_at_startup and
- was_used then
- Message2(unit_h_cond_not_set_in_last_compile,hs,current_module.mainsource^);
- end;
- end;
- procedure readsourcefiles;
- var
- temp,hs : string;
- temp_dir : string;
- main_dir : string;
- incfile_found,
- main_found,
- is_main : boolean;
- ppufiletime,
- source_time : longint;
- hp : tinputfile;
- begin
- ppufiletime:=getnamedfiletime(current_module.ppufilename^);
- current_module.sources_avail:=true;
- is_main:=true;
- main_dir:='';
- while not current_ppu^.endofentry do
- begin
- hs:=current_ppu^.getstring;
- temp_dir:='';
- if (current_module.flags and uf_in_library)<>0 then
- begin
- current_module.sources_avail:=false;
- temp:=' library';
- end
- else if pos('Macro ',hs)=1 then
- begin
- { we don't want to find this file }
- { but there is a problem with file indexing !! }
- temp:='';
- end
- else
- begin
- { check the date of the source files }
- Source_Time:=GetNamedFileTime(current_module.path^+hs);
- incfile_found:=false;
- main_found:=false;
- if Source_Time<>-1 then
- hs:=current_module.path^+hs
- else
- if not(is_main) then
- begin
- Source_Time:=GetNamedFileTime(main_dir+hs);
- if Source_Time<>-1 then
- hs:=main_dir+hs;
- end;
- if (Source_Time=-1) then
- begin
- if is_main then
- main_found:=unitsearchpath.FindFile(hs,temp_dir)
- else
- incfile_found:=includesearchpath.FindFile(hs,temp_dir);
- if incfile_found or main_found then
- Source_Time:=GetNamedFileTime(temp_dir);
- end;
- if Source_Time=-1 then
- begin
- current_module.sources_avail:=false;
- temp:=' not found';
- end
- else
- begin
- if main_found then
- main_dir:=temp_dir;
- { time newer? But only allow if the file is not searched
- in the include path (PFV), else you've problems with
- units which use the same includefile names }
- if incfile_found then
- temp:=' found'
- else
- begin
- temp:=' time '+filetimestring(source_time);
- if (source_time>ppufiletime) then
- begin
- current_module.do_compile:=true;
- current_module.recompile_reason:=rr_sourcenewer;
- temp:=temp+' *'
- end;
- end;
- end;
- hp:=tinputfile.create(hs);
- { the indexing is wrong here PM }
- current_module.sourcefiles.register_file(hp);
- end;
- if is_main then
- begin
- stringdispose(current_module.mainsource);
- current_module.mainsource:=stringdup(hs);
- end;
- Message1(unit_u_ppu_source,hs+temp);
- is_main:=false;
- end;
- { check if we want to rebuild every unit, only if the sources are
- available }
- if do_build and current_module.sources_avail then
- begin
- current_module.do_compile:=true;
- current_module.recompile_reason:=rr_build;
- end;
- end;
- procedure readloadunit;
- var
- hs : string;
- intfchecksum,
- checksum : longint;
- in_interface : boolean;
- begin
- while not current_ppu^.endofentry do
- begin
- hs:=current_ppu^.getstring;
- checksum:=current_ppu^.getlongint;
- intfchecksum:=current_ppu^.getlongint;
- in_interface:=(current_ppu^.getbyte<>0);
- current_module.used_units.concat(tused_unit.create_to_load(hs,checksum,intfchecksum,in_interface));
- end;
- end;
- procedure readlinkcontainer(var p:tlinkcontainer);
- var
- s : string;
- m : longint;
- begin
- while not current_ppu^.endofentry do
- begin
- s:=current_ppu^.getstring;
- m:=current_ppu^.getlongint;
- p.add(s,m);
- end;
- end;
- procedure load_interface;
- var
- b : byte;
- newmodulename : string;
- begin
- { read interface part }
- repeat
- b:=current_ppu^.readentry;
- case b of
- ibmodulename :
- begin
- newmodulename:=current_ppu^.getstring;
- if upper(newmodulename)<>current_module.modulename^ then
- Message2(unit_f_unit_name_error,current_module.realmodulename^,newmodulename);
- stringdispose(current_module.modulename);
- stringdispose(current_module.realmodulename);
- current_module.modulename:=stringdup(upper(newmodulename));
- current_module.realmodulename:=stringdup(newmodulename);
- end;
- ibsourcefiles :
- readsourcefiles;
- ibusedmacros :
- readusedmacros;
- ibloadunit :
- readloadunit;
- iblinkunitofiles :
- readlinkcontainer(current_module.LinkUnitOFiles);
- iblinkunitstaticlibs :
- readlinkcontainer(current_module.LinkUnitStaticLibs);
- iblinkunitsharedlibs :
- readlinkcontainer(current_module.LinkUnitSharedLibs);
- iblinkotherofiles :
- readlinkcontainer(current_module.LinkotherOFiles);
- iblinkotherstaticlibs :
- readlinkcontainer(current_module.LinkotherStaticLibs);
- iblinkothersharedlibs :
- readlinkcontainer(current_module.LinkotherSharedLibs);
- ibendinterface :
- break;
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- until false;
- end;
- {****************************************************************************
- TUNITSYMTABLE
- ****************************************************************************}
- constructor tunitsymtable.init(t : tsymtabletype; const n : string);
- begin
- inherited init(t);
- name:=stringdup(upper(n));
- unitid:=0;
- unitsym:=nil;
- symsearch^.usehash;
- { reset GDB things }
- {$ifdef GDB}
- if (t = globalsymtable) then
- begin
- prev_dbx_counter := dbx_counter;
- dbx_counter := nil;
- end;
- is_stab_written:=false;
- dbx_count := -1;
- if cs_gdb_dbx in aktglobalswitches then
- begin
- dbx_count := 0;
- unittypecount:=1;
- if (symtabletype=globalsymtable) then
- pglobaltypecount := @unittypecount;
- unitid:=current_module.unitcount;
- debugList.concat(Tai_asm_comment.Create(strpnew('Global '+name^+' has index '+tostr(unitid))));
- debugList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
- inc(current_module.unitcount);
- dbx_count_ok:=false;
- dbx_counter:=@dbx_count;
- do_count_dbx:=true;
- end;
- {$endif GDB}
- end;
- constructor tunitsymtable.loadasunit;
- var
- {$ifdef GDB}
- storeGlobalTypeCount : pword;
- {$endif GDB}
- b : byte;
- begin
- unitsym:=nil;
- unitid:=0;
- {$ifdef GDB}
- if cs_gdb_dbx in aktglobalswitches then
- begin
- UnitTypeCount:=1;
- storeGlobalTypeCount:=PGlobalTypeCount;
- PglobalTypeCount:=@UnitTypeCount;
- end;
- {$endif GDB}
- { load symtables }
- inherited loadas(unitsymtable);
- { set the name after because it is set to nil in tstoredsymtable.load !! }
- name:=stringdup(current_module.modulename^);
- { dbx count }
- {$ifdef GDB}
- if (current_module.flags and uf_has_dbx)<>0 then
- begin
- b := current_ppu^.readentry;
- if b <> ibdbxcount then
- Message(unit_f_ppu_dbx_count_problem)
- else
- dbx_count := readlong;
- dbx_count_ok := {true}false;
- end
- else
- begin
- dbx_count := -1;
- dbx_count_ok:=false;
- end;
- if cs_gdb_dbx in aktglobalswitches then
- PGlobalTypeCount:=storeGlobalTypeCount;
- is_stab_written:=false;
- {$endif GDB}
- b:=current_ppu^.readentry;
- if b<>ibendimplementation then
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- destructor tunitsymtable.done;
- var
- pus : punitsym;
- begin
- pus:=unitsym;
- while assigned(pus) do
- begin
- unitsym:=pus^.prevsym;
- pus^.prevsym:=nil;
- pus^.unitsymtable:=nil;
- pus:=unitsym;
- end;
- inherited done;
- end;
- procedure tunitsymtable.load_symtable_refs;
- var
- b : byte;
- unitindex : word;
- begin
- if ((current_module.flags and uf_local_browser)<>0) then
- begin
- current_module.localsymtable:=new(punitsymtable,loadas(staticppusymtable));
- psymtable(current_module.localsymtable)^.name:=
- stringdup('implementation of '+psymtable(current_module.globalsymtable)^.name^);
- end;
- { load browser }
- if (current_module.flags and uf_has_browser)<>0 then
- begin
- {if not (cs_browser in aktmoduleswitches) then
- current_ppu^.skipuntilentry(ibendbrowser)
- else }
- begin
- load_browser;
- unitindex:=1;
- while assigned(current_module.map^[unitindex]) do
- begin
- {each unit wrote one browser entry }
- load_browser;
- inc(unitindex);
- end;
- b:=current_ppu^.readentry;
- if b<>ibendbrowser then
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- end;
- if ((current_module.flags and uf_local_browser)<>0) then
- pstoredsymtable(current_module.localsymtable)^.load_browser;
- end;
- procedure tunitsymtable.writeasunit;
- var
- pu : tused_unit;
- begin
- { first the unitname }
- current_ppu^.putstring(current_module.realmodulename^);
- current_ppu^.writeentry(ibmodulename);
- writesourcefiles;
- writeusedmacros;
- writeusedunit;
- { write the objectfiles and libraries that come for this unit,
- preserve the containers becuase they are still needed to load
- the link.res. All doesn't depend on the crc! It doesn't matter
- if a unit is in a .o or .a file }
- current_ppu^.do_crc:=false;
- writelinkcontainer(current_module.linkunitofiles,iblinkunitofiles,true);
- writelinkcontainer(current_module.linkunitstaticlibs,iblinkunitstaticlibs,true);
- writelinkcontainer(current_module.linkunitsharedlibs,iblinkunitsharedlibs,true);
- writelinkcontainer(current_module.linkotherofiles,iblinkotherofiles,false);
- writelinkcontainer(current_module.linkotherstaticlibs,iblinkotherstaticlibs,true);
- writelinkcontainer(current_module.linkothersharedlibs,iblinkothersharedlibs,true);
- current_ppu^.do_crc:=true;
- current_ppu^.writeentry(ibendinterface);
- { write the symtable entries }
- inherited writeas;
- { all after doesn't affect crc }
- current_ppu^.do_crc:=false;
- { write dbx count }
- {$ifdef GDB}
- if cs_gdb_dbx in aktglobalswitches then
- begin
- {$IfDef EXTDEBUG}
- writeln('Writing dbx_count ',dbx_count,' in unit ',name^,'.ppu');
- {$ENDIF EXTDEBUG}
- current_ppu^.putlongint(dbx_count);
- current_ppu^.writeentry(ibdbxcount);
- end;
- {$endif GDB}
- current_ppu^.writeentry(ibendimplementation);
- { write static symtable
- needed for local debugging of unit functions }
- if ((current_module.flags and uf_local_browser)<>0) and
- assigned(current_module.localsymtable) then
- pstoredsymtable(current_module.localsymtable)^.writeas;
- { write all browser section }
- if (current_module.flags and uf_has_browser)<>0 then
- begin
- write_browser;
- pu:=tused_unit(current_module.used_units.first);
- while assigned(pu) do
- begin
- pstoredsymtable(pu.u.globalsymtable)^.write_browser;
- pu:=tused_unit(pu.next);
- end;
- current_ppu^.writeentry(ibendbrowser);
- end;
- if ((current_module.flags and uf_local_browser)<>0) and
- assigned(current_module.localsymtable) then
- pstoredsymtable(current_module.localsymtable)^.write_browser;
- { the last entry ibend is written automaticly }
- end;
- {$ifdef GDB}
- function tunitsymtable.getnewtypecount : word;
- begin
- if not (cs_gdb_dbx in aktglobalswitches) then
- getnewtypecount:=tsymtable.getnewtypecount
- else
- if symtabletype = staticsymtable then
- getnewtypecount:=tsymtable.getnewtypecount
- else
- begin
- getnewtypecount:=unittypecount;
- inc(unittypecount);
- end;
- end;
- procedure tunitsymtable.concattypestabto(asmlist : taasmoutput);
- var prev_dbx_count : plongint;
- begin
- if is_stab_written then exit;
- if not assigned(name) then name := stringdup('Main_program');
- if (symtabletype = unitsymtable) and
- (current_module.globalsymtable<>@Self) then
- begin
- unitid:=current_module.unitcount;
- inc(current_module.unitcount);
- end;
- asmList.concat(Tai_asm_comment.Create(strpnew('Begin unit '+name^
- +' has index '+tostr(unitid))));
- if cs_gdb_dbx in aktglobalswitches then
- begin
- if dbx_count_ok then
- begin
- asmList.concat(Tai_asm_comment.Create(strpnew('"repeated" unit '+name^
- +' has index '+tostr(unitid)+' dbx count = '+tostr(dbx_count))));
- asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
- +tostr(N_EXCL)+',0,0,'+tostr(dbx_count))));
- exit;
- end
- else if (current_module.globalsymtable<>@Self) then
- begin
- prev_dbx_count := dbx_counter;
- dbx_counter := nil;
- do_count_dbx:=false;
- if symtabletype = unitsymtable then
- asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')));
- dbx_counter := @dbx_count;
- dbx_count:=0;
- do_count_dbx:=assigned(dbx_counter);
- end;
- end;
- asmoutput:=asmlist;
- foreach({$ifdef FPCPROCVAR}@{$endif}concattypestab);
- if cs_gdb_dbx in aktglobalswitches then
- begin
- if (current_module.globalsymtable<>@Self) then
- begin
- dbx_counter := prev_dbx_count;
- do_count_dbx:=false;
- asmList.concat(Tai_asm_comment.Create(strpnew('End unit '+name^
- +' has index '+tostr(unitid))));
- asmList.concat(Tai_stabs.Create(strpnew('"'+name^+'",'
- +tostr(N_EINCL)+',0,0,0')));
- do_count_dbx:=assigned(dbx_counter);
- dbx_count_ok := {true}false;
- end;
- end;
- is_stab_written:=true;
- end;
- {$endif}
- {*****************************************************************************
- Helper Routines
- *****************************************************************************}
- procedure numberunits;
- var
- counter : longint;
- hp : tused_unit;
- hp1 : tmodule;
- begin
- { Reset all numbers to -1 }
- hp1:=tmodule(loaded_units.first);
- while assigned(hp1) do
- begin
- if assigned(hp1.globalsymtable) then
- psymtable(hp1.globalsymtable)^.unitid:=$ffff;
- hp1:=tmodule(hp1.next);
- end;
- { Our own symtable gets unitid 0, for a program there is
- no globalsymtable }
- if assigned(current_module.globalsymtable) then
- psymtable(current_module.globalsymtable)^.unitid:=0;
- { number units }
- counter:=1;
- hp:=tused_unit(current_module.used_units.first);
- while assigned(hp) do
- begin
- psymtable(hp.u.globalsymtable)^.unitid:=counter;
- inc(counter);
- hp:=tused_unit(hp.next);
- end;
- end;
- function findunitsymtable(st:psymtable):psymtable;
- begin
- findunitsymtable:=nil;
- repeat
- if not assigned(st) then
- internalerror(5566561);
- case st^.symtabletype of
- localsymtable,
- parasymtable,
- staticsymtable :
- break;
- globalsymtable,
- unitsymtable :
- begin
- findunitsymtable:=st;
- break;
- end;
- objectsymtable,
- recordsymtable :
- st:=st^.defowner^.owner;
- else
- internalerror(5566562);
- end;
- until false;
- end;
- procedure duplicatesym(sym:psym);
- var
- st : psymtable;
- begin
- Message1(sym_e_duplicate_id,sym^.realname);
- st:=findunitsymtable(sym^.owner);
- with sym^.fileinfo do
- begin
- if assigned(st) and (st^.unitid<>0) then
- Message2(sym_h_duplicate_id_where,'unit '+st^.name^,tostr(line))
- else
- Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line));
- end;
- end;
- procedure identifier_not_found(const s:string);
- begin
- Message1(sym_e_id_not_found,s);
- { show a fatal that you need -S2 or -Sd, but only
- if we just parsed the a token that has m_class }
- if not(m_class in aktmodeswitches) and
- (Upper(s)=pattern) and
- (tokeninfo^[idtoken].keyword=m_class) then
- Message(parser_f_need_objfpc_or_delphi_mode);
- end;
- {*****************************************************************************
- Search
- *****************************************************************************}
- function searchsym(const s : stringid;var srsym:psym;var srsymtable:psymtable):boolean;
- var
- speedvalue : longint;
- begin
- speedvalue:=getspeedvalue(s);
- srsymtable:=symtablestack;
- while assigned(srsymtable) do
- begin
- srsym:=psym(srsymtable^.speedsearch(s,speedvalue));
- if assigned(srsym) then
- begin
- searchsym:=true;
- exit;
- end
- else
- srsymtable:=srsymtable^.next;
- end;
- searchsym:=false;
- end;
- function searchsymonlyin(p : psymtable;const s : stringid):psym;
- var
- srsym : psym;
- begin
- { the caller have to take care if srsym=nil }
- if assigned(p) then
- begin
- srsym:=psym(p^.search(s));
- if assigned(srsym) then
- begin
- searchsymonlyin:=srsym;
- exit;
- end;
- { also check in the local symtbale if it exists }
- if (punitsymtable(p)=punitsymtable(current_module.globalsymtable)) then
- begin
- srsym:=psym(psymtable(current_module.localsymtable)^.search(s));
- if assigned(srsym) then
- begin
- searchsymonlyin:=srsym;
- exit;
- end;
- end
- end;
- searchsymonlyin:=nil;
- end;
- function search_class_member(pd : pobjectdef;const s : string):psym;
- { searches n in symtable of pd and all anchestors }
- var
- speedvalue : longint;
- srsym : psym;
- begin
- speedvalue:=getspeedvalue(s);
- while assigned(pd) do
- begin
- srsym:=psym(pd^.symtable^.speedsearch(s,speedvalue));
- if assigned(srsym) then
- begin
- search_class_member:=srsym;
- exit;
- end;
- pd:=pd^.childof;
- end;
- search_class_member:=nil;
- end;
- function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym;
- {Search for a symbol in a specified symbol table. Returns nil if
- the symtable is not found, and also if the symbol cannot be found
- in the desired symtable }
- var hsymtab:Psymtable;
- res:Psym;
- begin
- res:=nil;
- hsymtab:=symtablestack;
- while (hsymtab<>nil) and (hsymtab^.symtabletype<>symtabletype) do
- hsymtab:=hsymtab^.next;
- if hsymtab<>nil then
- {We found the desired symtable. Now check if the symbol we
- search for is defined in it }
- res:=psym(hsymtab^.search(symbol));
- search_a_symtable:=res;
- end;
- {*****************************************************************************
- Definition Helpers
- *****************************************************************************}
- function globaldef(const s : string) : pdef;
- var st : string;
- symt : psymtable;
- srsym : psym;
- srsymtable : psymtable;
- begin
- srsym := nil;
- if pos('.',s) > 0 then
- begin
- st := copy(s,1,pos('.',s)-1);
- searchsym(st,srsym,srsymtable);
- st := copy(s,pos('.',s)+1,255);
- if assigned(srsym) then
- begin
- if srsym^.typ = unitsym then
- begin
- symt := punitsym(srsym)^.unitsymtable;
- srsym := psym(symt^.search(st));
- end else srsym := nil;
- end;
- end else st := s;
- if srsym = nil then
- searchsym(st,srsym,srsymtable);
- if srsym = nil then
- srsym:=searchsymonlyin(systemunit,st);
- if (not assigned(srsym)) or
- (srsym^.typ<>typesym) then
- begin
- Message(type_e_type_id_expected);
- exit;
- end;
- globaldef := pdef(ptypesym(srsym)^.restype.def);
- end;
- {****************************************************************************
- Object Helpers
- ****************************************************************************}
- var
- _defaultprop : ppropertysym;
- procedure testfordefaultproperty(p : pnamedindexobject);
- begin
- if (psym(p)^.typ=propertysym) and
- (ppo_defaultproperty in ppropertysym(p)^.propoptions) then
- _defaultprop:=ppropertysym(p);
- end;
- function search_default_property(pd : pobjectdef) : ppropertysym;
- { returns the default property of a class, searches also anchestors }
- begin
- _defaultprop:=nil;
- while assigned(pd) do
- begin
- pd^.symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}testfordefaultproperty);
- if assigned(_defaultprop) then
- break;
- pd:=pd^.childof;
- end;
- search_default_property:=_defaultprop;
- end;
- {$ifdef UNITALIASES}
- {****************************************************************************
- TUNIT_ALIAS
- ****************************************************************************}
- constructor tunit_alias.init(const n:string);
- var
- i : longint;
- begin
- i:=pos('=',n);
- if i=0 then
- fail;
- inherited initname(Copy(n,1,i-1));
- newname:=stringdup(Copy(n,i+1,255));
- end;
- destructor tunit_alias.done;
- begin
- stringdispose(newname);
- inherited done;
- end;
- procedure addunitalias(const n:string);
- begin
- unitaliases^.insert(new(punit_alias,init(Upper(n))));
- end;
- function getunitalias(const n:string):string;
- var
- p : punit_alias;
- begin
- p:=punit_alias(unitaliases^.search(Upper(n)));
- if assigned(p) then
- getunitalias:=punit_alias(p)^.newname^
- else
- getunitalias:=n;
- end;
- {$endif UNITALIASES}
- {****************************************************************************
- Symtable Stack
- ****************************************************************************}
- procedure dellexlevel;
- var
- p : psymtable;
- begin
- p:=symtablestack;
- symtablestack:=p^.next;
- { symbol tables of unit interfaces are never disposed }
- { this is handle by the unit unitm }
- if not(p^.symtabletype in [unitsymtable,globalsymtable,stt_exceptsymtable]) then
- dispose(p,done);
- end;
- procedure RestoreUnitSyms;
- var
- p : psymtable;
- begin
- p:=symtablestack;
- while assigned(p) do
- begin
- if (p^.symtabletype=unitsymtable) and
- assigned(punitsymtable(p)^.unitsym) and
- ((punitsymtable(p)^.unitsym^.owner=psymtable(current_module.globalsymtable)) or
- (punitsymtable(p)^.unitsym^.owner=psymtable(current_module.localsymtable))) then
- punitsymtable(p)^.unitsym^.restoreunitsym;
- p:=p^.next;
- end;
- end;
- {$ifdef DEBUG}
- procedure test_symtablestack;
- var
- p : psymtable;
- i : longint;
- begin
- p:=symtablestack;
- i:=0;
- while assigned(p) do
- begin
- inc(i);
- p:=p^.next;
- if i>500 then
- Message(sym_f_internal_error_in_symtablestack);
- end;
- end;
- procedure list_symtablestack;
- var
- p : psymtable;
- i : longint;
- begin
- p:=symtablestack;
- i:=0;
- while assigned(p) do
- begin
- inc(i);
- writeln(i,' ',p^.name^);
- p:=p^.next;
- if i>500 then
- Message(sym_f_internal_error_in_symtablestack);
- end;
- end;
- {$endif DEBUG}
- {****************************************************************************
- Init/Done Symtable
- ****************************************************************************}
- procedure InitSymtable;
- var
- token : ttoken;
- begin
- { Reset symbolstack }
- registerdef:=false;
- read_member:=false;
- symtablestack:=nil;
- systemunit:=nil;
- {$ifdef GDB}
- firstglobaldef:=nil;
- lastglobaldef:=nil;
- globaltypecount:=1;
- pglobaltypecount:=@globaltypecount;
- {$endif GDB}
- { create error syms and def }
- generrorsym:=new(perrorsym,init);
- generrordef:=new(perrordef,init);
- {$ifdef UNITALIASES}
- { unit aliases }
- unitaliases:=new(pdictionary,init);
- {$endif}
- for token:=first_overloaded to last_overloaded do
- overloaded_operators[token]:=nil;
- end;
- procedure DoneSymtable;
- begin
- dispose(generrorsym,done);
- dispose(generrordef,done);
- {$ifdef UNITALIASES}
- dispose(unitaliases,done);
- {$endif}
- end;
- end.
- {
- $Log$
- Revision 1.28 2001-03-13 18:45:07 peter
- * fixed some memory leaks
- Revision 1.27 2001/03/11 22:58:51 peter
- * getsym redesign, removed the globals srsym,srsymtable
- Revision 1.26 2001/02/21 19:37:19 peter
- * moved deref to be done after loading of implementation units. prederef
- is still done directly after loading of symbols and definitions.
- Revision 1.25 2001/02/20 21:41:16 peter
- * new fixfilename, findfile for unix. Look first for lowercase, then
- NormalCase and last for UPPERCASE names.
- Revision 1.24 2001/01/08 21:40:27 peter
- * fixed crash with unsupported token overloading
- Revision 1.23 2000/12/25 00:07:30 peter
- + new tlinkedlist class (merge of old tstringqueue,tcontainer and
- tlinkedlist objects)
- Revision 1.22 2000/12/23 19:50:09 peter
- * fixed mem leak with withsymtable
- Revision 1.21 2000/12/10 20:25:32 peter
- * fixed missing typecast
- Revision 1.20 2000/12/10 14:14:51 florian
- * fixed web bug 1203: class fields can be now redefined
- in Delphi mode though I don't like this :/
- Revision 1.19 2000/11/30 22:16:49 florian
- * moved to i386
- Revision 1.18 2000/11/29 00:30:42 florian
- * unused units removed from uses clause
- * some changes for widestrings
- Revision 1.17 2000/11/28 00:28:07 pierre
- * stabs fixing
- Revision 1.1.2.8 2000/11/17 11:14:37 pierre
- * one more class stabs fix
- Revision 1.16 2000/11/12 22:17:47 peter
- * some realname updates for messages
- Revision 1.15 2000/11/06 15:54:15 florian
- * fixed two bugs to get make cycle work, but it's not enough
- Revision 1.14 2000/11/04 14:25:22 florian
- + merged Attila's changes for interfaces, not tested yet
- Revision 1.13 2000/11/01 23:04:38 peter
- * tprocdef.fullprocname added for better casesensitve writing of
- procedures
- Revision 1.12 2000/10/31 22:02:52 peter
- * symtable splitted, no real code changes
- Revision 1.1.2.7 2000/10/16 19:43:04 pierre
- * trying to correct class stabss once more
- Revision 1.11 2000/10/15 07:47:53 peter
- * unit names and procedure names are stored mixed case
- Revision 1.10 2000/10/14 10:14:53 peter
- * moehrendorf oct 2000 rewrite
- Revision 1.9 2000/10/01 19:48:25 peter
- * lot of compile updates for cg11
- Revision 1.8 2000/09/24 15:06:29 peter
- * use defines.inc
- Revision 1.7 2000/08/27 16:11:54 peter
- * moved some util functions from globals,cobjects to cutils
- * splitted files into finput,fmodule
- Revision 1.6 2000/08/21 11:27:45 pierre
- * fix the stabs problems
- Revision 1.5 2000/08/20 14:58:41 peter
- * give fatal if objfpc/delphi mode things are found (merged)
- Revision 1.1.2.6 2000/08/20 14:56:46 peter
- * give fatal if objfpc/delphi mode things are found
- Revision 1.4 2000/08/16 18:33:54 peter
- * splitted namedobjectitem.next into indexnext and listnext so it
- can be used in both lists
- * don't allow "word = word" type definitions (merged)
- Revision 1.3 2000/08/08 19:28:57 peter
- * memdebug/memory patches (merged)
- * only once illegal directive (merged)
- }
|