123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480 |
- {
- $Id$
- Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
- Implementation of the reading of PPU Files for the symtable
- 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 symppu;
- {$i fpcdefs.inc}
- interface
- uses
- cclasses,
- globtype,globals,
- cpuinfo,aasmbase,
- symbase,symtype,
- ppu;
- type
- tcompilerppufile=class(tppufile)
- public
- procedure checkerror;
- procedure getguid(var g: tguid);
- function getexprint:tconstexprint;
- function getptruint:TConstPtrUInt;
- procedure getposinfo(var p:tfileposinfo);
- procedure getderef(var d:tderef);
- function getsymlist:tsymlist;
- procedure gettype(var t:ttype);
- function getasmsymbol:tasmsymbol;
- procedure putguid(const g: tguid);
- procedure putexprint(v:tconstexprint);
- procedure PutPtrUInt(v:TConstPtrUInt);
- procedure putposinfo(const p:tfileposinfo);
- procedure putderef(const d:tderef);
- procedure putsymlist(p:tsymlist);
- procedure puttype(const t:ttype);
- procedure putasmsymbol(s:tasmsymbol);
- end;
- implementation
- uses
- symconst,
- verbose;
- {*****************************************************************************
- TCompilerPPUFile
- *****************************************************************************}
- procedure tcompilerppufile.checkerror;
- begin
- if error then
- Message(unit_f_ppu_read_error);
- end;
- procedure tcompilerppufile.getguid(var g: tguid);
- begin
- getdata(g,sizeof(g));
- end;
- function tcompilerppufile.getexprint:tconstexprint;
- var
- l1,l2 : longint;
- begin
- if sizeof(tconstexprint)=8 then
- begin
- l1:=getlongint;
- l2:=getlongint;
- {$ifopt R+}
- {$define Range_check_on}
- {$endif opt R+}
- {$R- needed here }
- {$ifdef Delphi}
- result:=int64(l1)+(int64(l2) shl 32);
- {$else}
- result:=qword(l1)+(int64(l2) shl 32);
- {$endif}
- {$ifdef Range_check_on}
- {$R+}
- {$undef Range_check_on}
- {$endif Range_check_on}
- end
- else
- result:=getlongint;
- end;
- function tcompilerppufile.getPtrUInt:TConstPtrUInt;
- var
- l1,l2 : longint;
- begin
- if sizeof(tconstexprint)=8 then
- begin
- l1:=getlongint;
- l2:=getlongint;
- {$ifopt R+}
- {$define Range_check_on}
- {$endif opt R+}
- {$R- needed here }
- {$ifdef Delphi}
- result:=int64(l1)+(int64(l2) shl 32);
- {$else}
- result:=qword(l1)+(int64(l2) shl 32);
- {$endif}
- {$ifdef Range_check_on}
- {$R+}
- {$undef Range_check_on}
- {$endif Range_check_on}
- end
- else
- result:=getlongint;
- end;
- procedure tcompilerppufile.getposinfo(var p:tfileposinfo);
- var
- info : byte;
- begin
- {
- info byte layout in bits:
- 0-1 - amount of bytes for fileindex
- 2-3 - amount of bytes for line
- 4-5 - amount of bytes for column
- }
- info:=getbyte;
- case (info and $03) of
- 0 : p.fileindex:=getbyte;
- 1 : p.fileindex:=getword;
- 2 : p.fileindex:=(getbyte shl 16) or getword;
- 3 : p.fileindex:=getlongint;
- end;
- case ((info shr 2) and $03) of
- 0 : p.line:=getbyte;
- 1 : p.line:=getword;
- 2 : p.line:=(getbyte shl 16) or getword;
- 3 : p.line:=getlongint;
- end;
- case ((info shr 4) and $03) of
- 0 : p.column:=getbyte;
- 1 : p.column:=getword;
- 2 : p.column:=(getbyte shl 16) or getword;
- 3 : p.column:=getlongint;
- end;
- end;
- procedure tcompilerppufile.getderef(var d:tderef);
- begin
- d.dataidx:=getlongint;
- end;
- function tcompilerppufile.getsymlist:tsymlist;
- var
- symderef : tderef;
- tt : ttype;
- slt : tsltype;
- idx : longint;
- p : tsymlist;
- begin
- p:=tsymlist.create;
- getderef(p.procdefderef);
- repeat
- slt:=tsltype(getbyte);
- case slt of
- sl_none :
- break;
- sl_call,
- sl_load,
- sl_subscript :
- begin
- getderef(symderef);
- p.addsymderef(slt,symderef);
- end;
- sl_typeconv :
- begin
- gettype(tt);
- p.addtype(slt,tt);
- end;
- sl_vec :
- begin
- idx:=getlongint;
- p.addconst(slt,idx);
- end;
- else
- internalerror(200110204);
- end;
- until false;
- getsymlist:=tsymlist(p);
- end;
- procedure tcompilerppufile.gettype(var t:ttype);
- begin
- getderef(t.deref);
- t.def:=nil;
- t.sym:=nil;
- end;
- function tcompilerppufile.getasmsymbol:tasmsymbol;
- begin
- getasmsymbol:=tasmsymbol(pointer(getlongint));
- end;
- procedure tcompilerppufile.putposinfo(const p:tfileposinfo);
- var
- oldcrc : boolean;
- info : byte;
- begin
- { posinfo is not relevant for changes in PPU }
- oldcrc:=do_crc;
- do_crc:=false;
- {
- info byte layout in bits:
- 0-1 - amount of bytes for fileindex
- 2-3 - amount of bytes for line
- 4-5 - amount of bytes for column
- }
- info:=0;
- { calculate info byte }
- if (p.fileindex>$ff) then
- begin
- if (p.fileindex<=$ffff) then
- info:=info or $1
- else
- if (p.fileindex<=$ffffff) then
- info:=info or $2
- else
- info:=info or $3;
- end;
- if (p.line>$ff) then
- begin
- if (p.line<=$ffff) then
- info:=info or $4
- else
- if (p.line<=$ffffff) then
- info:=info or $8
- else
- info:=info or $c;
- end;
- if (p.column>$ff) then
- begin
- if (p.column<=$ffff) then
- info:=info or $10
- else
- if (p.column<=$ffffff) then
- info:=info or $20
- else
- info:=info or $30;
- end;
- { write data }
- putbyte(info);
- case (info and $03) of
- 0 : putbyte(p.fileindex);
- 1 : putword(p.fileindex);
- 2 : begin
- putbyte(p.fileindex shr 16);
- putword(p.fileindex and $ffff);
- end;
- 3 : putlongint(p.fileindex);
- end;
- case ((info shr 2) and $03) of
- 0 : putbyte(p.line);
- 1 : putword(p.line);
- 2 : begin
- putbyte(p.line shr 16);
- putword(p.line and $ffff);
- end;
- 3 : putlongint(p.line);
- end;
- case ((info shr 4) and $03) of
- 0 : putbyte(p.column);
- 1 : putword(p.column);
- 2 : begin
- putbyte(p.column shr 16);
- putword(p.column and $ffff);
- end;
- 3 : putlongint(p.column);
- end;
- do_crc:=oldcrc;
- end;
- procedure tcompilerppufile.putguid(const g: tguid);
- begin
- putdata(g,sizeof(g));
- end;
- procedure tcompilerppufile.putexprint(v:tconstexprint);
- begin
- if sizeof(TConstExprInt)=8 then
- begin
- putlongint(longint(lo(v)));
- putlongint(longint(hi(v)));
- end
- else if sizeof(TConstExprInt)=4 then
- putlongint(longint(v))
- else
- internalerror(2002082601);
- end;
- procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
- begin
- if sizeof(TConstPtrUInt)=8 then
- begin
- putlongint(longint(lo(v)));
- putlongint(longint(hi(v)));
- end
- else if sizeof(TConstPtrUInt)=4 then
- putlongint(longint(v))
- else
- internalerror(2002082601);
- end;
- procedure tcompilerppufile.putderef(const d:tderef);
- var
- oldcrc : boolean;
- begin
- oldcrc:=do_crc;
- do_crc:=false;
- putlongint(d.dataidx);
- do_crc:=oldcrc;
- end;
- procedure tcompilerppufile.putsymlist(p:tsymlist);
- var
- hp : psymlistitem;
- begin
- putderef(p.procdefderef);
- hp:=p.firstsym;
- while assigned(hp) do
- begin
- putbyte(byte(hp^.sltype));
- case hp^.sltype of
- sl_call,
- sl_load,
- sl_subscript :
- putderef(hp^.symderef);
- sl_typeconv :
- puttype(hp^.tt);
- sl_vec :
- putlongint(hp^.value);
- else
- internalerror(200110205);
- end;
- hp:=hp^.next;
- end;
- putbyte(byte(sl_none));
- end;
- procedure tcompilerppufile.puttype(const t:ttype);
- begin
- putderef(t.deref);
- end;
- procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
- begin
- if assigned(s) then
- begin
- if s.ppuidx=-1 then
- begin
- inc(objectlibrary.asmsymbolppuidx);
- s.ppuidx:=objectlibrary.asmsymbolppuidx;
- end;
- putlongint(s.ppuidx);
- end
- else
- putlongint(0);
- end;
- end.
- {
- $Log$
- Revision 1.23 2003-10-28 15:36:01 peter
- * absolute to object field supported, fixes tb0458
- Revision 1.22 2003/10/23 14:44:07 peter
- * splitted buildderef and buildderefimpl to fix interface crc
- calculation
- Revision 1.21 2003/10/22 20:40:00 peter
- * write derefdata in a separate ppu entry
- Revision 1.20 2003/10/07 16:06:30 peter
- * tsymlist.def renamed to tsymlist.procdef
- * tsymlist.procdef is now only used to store the procdef
- Revision 1.19 2003/06/07 20:26:32 peter
- * re-resolving added instead of reloading from ppu
- * tderef object added to store deref info for resolving
- Revision 1.18 2002/12/21 13:07:34 peter
- * type redefine fix for tb0437
- Revision 1.17 2002/10/05 12:43:29 carl
- * fixes for Delphi 6 compilation
- (warning : Some features do not work under Delphi)
- Revision 1.16 2002/08/26 14:05:57 pierre
- * fixed compilation cycle with -Cr option by adding explicit
- longint typecast in PutPtrUInt and putexprint methods.
- + added checks for sizeof and internalerros if size is not handled.
- Revision 1.15 2002/08/18 20:06:26 peter
- * inlining is now also allowed in interface
- * renamed write/load to ppuwrite/ppuload
- * tnode storing in ppu
- * nld,ncon,nbas are already updated for storing in ppu
- Revision 1.14 2002/08/11 14:32:28 peter
- * renamed current_library to objectlibrary
- Revision 1.13 2002/08/11 13:24:14 peter
- * saving of asmsymbols in ppu supported
- * asmsymbollist global is removed and moved into a new class
- tasmlibrarydata that will hold the info of a .a file which
- corresponds with a single module. Added librarydata to tmodule
- to keep the library info stored for the module. In the future the
- objectfiles will also be stored to the tasmlibrarydata class
- * all getlabel/newasmsymbol and friends are moved to the new class
- Revision 1.12 2002/05/18 13:34:18 peter
- * readded missing revisions
- Revision 1.11 2002/05/16 19:46:45 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.9 2002/05/12 16:53:15 peter
- * moved entry and exitcode to ncgutil and cgobj
- * foreach gets extra argument for passing local data to the
- iterator function
- * -CR checks also class typecasts at runtime by changing them
- into as
- * fixed compiler to cycle with the -CR option
- * fixed stabs with elf writer, finally the global variables can
- be watched
- * removed a lot of routines from cga unit and replaced them by
- calls to cgobj
- * u32bit-s32bit updates for and,or,xor nodes. When one element is
- u32bit then the other is typecasted also to u32bit without giving
- a rangecheck warning/error.
- * fixed pascal calling method with reversing also the high tree in
- the parast, detected by tcalcst3 test
- Revision 1.8 2002/04/19 15:40:40 peter
- * optimize tfileposinfo writing, this reduces the ppu size with 20%
- }
|