From c80de3be274494f56b105d08313f49e88da96902 Mon Sep 17 00:00:00 2001 From: pierre Date: Wed, 20 May 1998 09:42:32 +0000 Subject: [PATCH] + UseTokenInfo now default * unit in interface uses and implementation uses gives error now * only one error for unknown symbol (uses lastsymknown boolean) the problem came from the label code ! + first inlined procedures and function work (warning there might be allowed cases were the result is still wrong !!) * UseBrower updated gives a global list of all position of all used symbols with switch -gb --- compiler/browser.pas | 93 +++-- compiler/cgi386.pas | 778 +++++++++++++++++++++++++++++++----------- compiler/cobjects.pas | 84 ++++- compiler/files.pas | 32 +- compiler/hcodegen.pas | 35 +- compiler/i386.pas | 29 +- compiler/parser.pas | 30 +- compiler/pass_1.pas | 178 ++++++---- compiler/pbase.pas | 44 +-- compiler/pdecl.pas | 40 +-- compiler/pexpr.pas | 45 ++- compiler/pmodules.pas | 109 ++++-- compiler/pp.pas | 25 +- compiler/pstatmnt.pas | 55 ++- compiler/ra68k.pas | 17 +- compiler/radi386.pas | 19 +- compiler/rai386.pas | 17 +- compiler/ratti386.pas | 17 +- compiler/scanner.pas | 217 ++---------- compiler/tgeni386.pas | 157 +++++++-- compiler/tree.pas | 128 ++++--- 21 files changed, 1412 insertions(+), 737 deletions(-) diff --git a/compiler/browser.pas b/compiler/browser.pas index 90f442192b..e879f8a3bf 100644 --- a/compiler/browser.pas +++ b/compiler/browser.pas @@ -23,24 +23,24 @@ unit browser; interface -uses globals, files; +uses globals,cobjects,files; type pref = ^tref; tref = object nextref : pref; - inputfile : pinputfile; - lineno : longint; - constructor init(ref : pref); - constructor load(var ref : pref;fileindex : word;line : longint); + posinfo : tfileposinfo; + moduleindex : word; + constructor init(ref : pref;pos : pfileposinfo); + constructor load(var ref : pref;fileindex : word;line,column : longint); destructor done; virtual; function get_file_line : string; end; { simple method to chain all refs } - procedure add_new_ref(var ref : pref); + procedure add_new_ref(var ref : pref;pos : pfileposinfo); - function get_source_file(index : word) : pinputfile; + function get_source_file(moduleindex,fileindex : word) : pinputfile; { one big problem remains for overloaded procedure } { we should be able to separate them } @@ -48,80 +48,95 @@ type implementation - constructor tref.init(ref :pref); + uses scanner,verbose; + + constructor tref.init(ref :pref;pos : pfileposinfo); begin nextref:=nil; if ref<>nil then ref^.nextref:=@self; + if assigned(pos) then + posinfo:=pos^; if current_module<>nil then begin - inputfile:=current_module^.current_inputfile; - if inputfile<>nil then - begin - inc(inputfile^.ref_index); - lineno:=inputfile^.line_no; - end - else - lineno:=0; - end - else - begin - inputfile:=nil; - lineno:=0; + moduleindex:=current_module^.unit_index; end; end; - constructor tref.load(var ref : pref;fileindex : word;line : longint); + constructor tref.load(var ref : pref;fileindex : word;line,column : longint); begin + moduleindex:=current_module^.unit_index; if assigned(ref) then ref^.nextref:=@self; nextref:=nil; - inputfile:=get_source_file(fileindex); - lineno:=line; + posinfo.fileindex:=fileindex; + posinfo.line:=line; + posinfo.column:=column; ref:=@self; end; destructor tref.done; + var + inputfile : pinputfile; begin + inputfile:=get_source_file(moduleindex,posinfo.fileindex); if inputfile<>nil then dec(inputfile^.ref_count); end; function tref.get_file_line : string; + var + inputfile : pinputfile; begin get_file_line:=''; - if inputfile=nil then exit; - if Use_Rhide then - get_file_line:=lowercase(inputfile^.name^+inputfile^.ext^)+':'+tostr(lineno)+':' + inputfile:=get_source_file(moduleindex,posinfo.fileindex); + if assigned(inputfile) then + if Use_Rhide then + get_file_line:=globals.lowercase(inputfile^.name^+inputfile^.ext^) + +':'+tostr(posinfo.line)+':'+tostr(posinfo.column)+':' + else + get_file_line:=inputfile^.name^+inputfile^.ext^ + +'('+tostr(posinfo.line)+','+tostr(posinfo.column)+')' else - get_file_line:=inputfile^.name^+inputfile^.ext^+'('+tostr(lineno)+')' + if Use_Rhide then + get_file_line:='file_unknown:' + +tostr(posinfo.line)+':'+tostr(posinfo.column)+':' + else + get_file_line:='file_unknown(' + +tostr(posinfo.line)+','+tostr(posinfo.column)+')' end; - procedure add_new_ref(var ref : pref); + procedure add_new_ref(var ref : pref;pos : pfileposinfo); var newref : pref; begin - new(newref,init(ref)); + new(newref,init(ref,pos)); ref:=newref; end; - function get_source_file(index : word) : pinputfile; + function get_source_file(moduleindex,fileindex : word) : pinputfile; var + hp : pmodule; f : pinputfile; begin + hp:=pmodule(loaded_units.first); + while assigned(hp) and (hp^.unit_index<>moduleindex) do + hp:=pmodule(hp^.next); get_source_file:=nil; - f:=pinputfile(current_module^.sourcefiles.files); + if not assigned(hp) then + exit; + f:=pinputfile(hp^.sourcefiles.files); while assigned(f) do begin - if f^.ref_index=index then + if f^.ref_index=fileindex then begin get_source_file:=f; exit; @@ -133,7 +148,17 @@ implementation end. { $Log$ - Revision 1.2 1998-04-30 15:59:39 pierre + Revision 1.3 1998-05-20 09:42:32 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.2 1998/04/30 15:59:39 pierre * GDB works again better : correct type info in one pass + UseTokenInfo for better source position diff --git a/compiler/cgi386.pas b/compiler/cgi386.pas index cf741cfee8..c2c39f2ffb 100644 --- a/compiler/cgi386.pas +++ b/compiler/cgi386.pas @@ -221,36 +221,24 @@ implementation begin { first handle local and temporary variables } if (symtabletype=parasymtable) or -{$ifdef TestInline} (symtabletype=inlinelocalsymtable) or (symtabletype=inlineparasymtable) or -{$endif TestInline} (symtabletype=localsymtable) then begin p^.location.reference.base:=procinfo.framepointer; p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; - if (symtabletype=localsymtable) then + if (symtabletype=localsymtable) or (symtabletype=inlinelocalsymtable) then p^.location.reference.offset:=-p^.location.reference.offset; - if (symtabletype=parasymtable) then + if (symtabletype=parasymtable) or (symtabletype=inlineparasymtable) then inc(p^.location.reference.offset,p^.symtable^.call_offset); -{$ifdef TestInline} - if (symtabletype=inlinelocalsymtable) then - p^.location.reference.offset:=-p^.location.reference.offset - +p^.symtable^.call_offset; - if (symtabletype=inlineparasymtable) then - inc(p^.location.reference.offset,p^.symtable^.call_offset); - { comment(v_fatal,'inline proc arg not replaced'); } -{$endif TestInline} if (lexlevel>(p^.symtable^.symtablelevel)) then begin hregister:=getregister32; { make a reference } - new(hp); - reset_reference(hp^); - hp^.offset:=procinfo.framepointer_offset; - hp^.base:=procinfo.framepointer; - + hp:=new_reference(procinfo.framepointer, + procinfo.framepointer_offset); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); simple_loadn:=false; @@ -258,11 +246,7 @@ implementation while i>(p^.symtable^.symtablelevel) do begin { make a reference } - new(hp); - reset_reference(hp^); - hp^.offset:=8; - hp^.base:=hregister; - + hp:=new_reference(hregister,8); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); dec(i); end; @@ -297,10 +281,11 @@ implementation hregister:=getregister32; p^.location.reference.base:=hregister; { make a reference } - new(hp); - reset_reference(hp^); - hp^.offset:=p^.symtable^.datasize; - hp^.base:=procinfo.framepointer; + { symtable datasize field + contains the offset of the temp + stored } + hp:=new_reference(procinfo.framepointer, + p^.symtable^.datasize); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); @@ -654,7 +639,10 @@ implementation end; end; stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,constreal)); + if assigned(lastlabel) then + p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,constreal)) + else + p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labnumber,constreal)); end; procedure secondfixconst(var p : ptree); @@ -763,7 +751,10 @@ implementation end; end; stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,conststring)); + if assigned(lastlabel) then + p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,conststring)) + else + p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labnumber,conststring)); p^.location.loc := LOC_MEM; end; @@ -1288,8 +1279,7 @@ implementation begin if p^.left^.resulttype^.deftype=arraydef then begin - new(hp); - reset_reference(hp^); + hp:=new_reference(R_NO,0); parraydef(p^.left^.resulttype)^.genrangecheck; hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr)); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp))); @@ -1410,8 +1400,7 @@ implementation hregister:=R_EDI; end else internalerror(6); - new(hp); - reset_reference(hp^); + hp:=new_reference(R_NO,0); hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr)); if porddef(p1)^.von>porddef(p1)^.bis then begin @@ -1423,8 +1412,7 @@ implementation exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); if porddef(p1)^.von>porddef(p1)^.bis then begin - new(hp); - reset_reference(hp^); + hp:=new_reference(R_NO,0); hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1)); emitl(A_JMP,poslabel); emitl(A_LABEL,neglabel); @@ -1738,10 +1726,8 @@ implementation if porddef(p^.left^.resulttype)^.typ=u32bit then push_int(0); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI))); - new(r); - reset_reference(r^); - r^.base:=R_ESP; - { for u32bit a solution would be to push $0 and to load a + r:=new_reference(R_ESP,0); + { for u32bit a solution is to push $0 and to load a comp } if porddef(p^.left^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IQ,r))) @@ -1955,16 +1941,13 @@ implementation else exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.location.reference),R_EDI))); - - new(hpp); - reset_reference(hpp^); + hpp:=new_reference(R_NO,0); hpp^.symbol:=stringdup('R_'+tostr(porddef(hp^.resulttype)^.rangenr)); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); { then we do a normal range check } porddef(p^.resulttype)^.genrangecheck; - new(hpp); - reset_reference(hpp^); + hpp:=new_reference(R_NO,0); hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr)); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); end @@ -2000,8 +1983,7 @@ implementation exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.location.reference),R_EDI))); end else internalerror(6); - new(hpp); - reset_reference(hpp^); + hpp:=new_reference(R_NO,0); hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr)); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); (* @@ -2382,7 +2364,10 @@ implementation pushedparasize : longint; procedure secondcallparan(var p : ptree;defcoll : pdefcoll; - push_from_left_to_right : boolean); + push_from_left_to_right : boolean + ;inlined : boolean; + para_offset : longint + ); procedure maybe_push_open_array_high; @@ -2395,19 +2380,31 @@ implementation if assigned(defcoll^.data) and is_open_array(defcoll^.data) then begin + inc(pushedparasize,4); { push high } if is_open_array(p^.left^.resulttype) then begin - new(r); - reset_reference(r^); - r^.base:=highframepointer; - r^.offset:=highoffset+4; + r:=new_reference(highframepointer,highoffset+4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); + end + else exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))); end else + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, + parraydef(p^.left^.resulttype)^.highrange- + parraydef(p^.left^.resulttype)^.lowrange,r))); + end + else push_int(parraydef(p^.left^.resulttype)^.highrange- parraydef(p^.left^.resulttype)^.lowrange); - inc(pushedparasize,4); end; end; @@ -2427,7 +2424,9 @@ implementation begin { push from left to right if specified } if push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right + ,inlined,para_offset + ); otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); @@ -2438,9 +2437,17 @@ implementation (defcoll^.data^.deftype=formaldef) then begin { allow @var } + inc(pushedparasize,4); if p^.left^.treetype=addrn then begin { always a register } + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + p^.left^.location.register,r))); + end + else exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); ungetregister32(p^.left^.location.register); end @@ -2451,11 +2458,19 @@ implementation Message(sym_e_type_mismatch) else begin + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); end; end; - inc(pushedparasize,4); end { handle call by reference parameter } else if (defcoll^.paratyp=vs_var) then @@ -2463,9 +2478,18 @@ implementation if (p^.left^.location.loc<>LOC_REFERENCE) then Message(cg_e_var_must_be_reference); maybe_push_open_array_high; + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); - inc(pushedparasize,4); end else begin @@ -2476,9 +2500,18 @@ implementation dont_copy_const_param(p^.resulttype) then begin maybe_push_open_array_high; - emitpushreferenceaddr(p^.left^.location.reference); - del_reference(p^.left^.location.reference); inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); end else case p^.left^.location.loc of @@ -2489,22 +2522,43 @@ implementation R_EAX,R_EBX,R_ECX,R_EDX,R_ESI, R_EDI,R_ESP,R_EBP : begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); inc(pushedparasize,4); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + p^.left^.location.register,r))); + end + else + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); ungetregister32(p^.left^.location.register); end; R_AX,R_BX,R_CX,R_DX,R_SI,R_DI: begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,p^.left^.location.register))); inc(pushedparasize,2); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, + p^.left^.location.register,r))); + end + else + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,p^.left^.location.register))); ungetregister32(reg16toreg32(p^.left^.location.register)); end; R_AL,R_BL,R_CL,R_DL: begin + inc(pushedparasize,2); { we must push always 16 bit } + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + reg8toreg16(p^.left^.location.register),r))); + end + else exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W, reg8toreg16(p^.left^.location.register)))); - inc(pushedparasize,2); ungetregister32(reg8toreg32(p^.left^.location.register)); end; end; @@ -2512,12 +2566,17 @@ implementation LOC_FPU: begin size:=pfloatdef(p^.left^.resulttype)^.size; - inc(pushedparasize,size); + inc(pushedparasize,size); { must be before for inlined } + if not inlined then exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); - new(r); - reset_reference(r^); - r^.base:=R_ESP; + r:=new_reference(R_ESP,0); floatstoreops(pfloatdef(p^.left^.resulttype)^.typ,op,s); + { this is the easiest case for inlined !! } + if inlined then + begin + r^.base:=procinfo.framepointer; + r^.offset:=para_offset-pushedparasize; + end; exprasmlist^.concat(new(pai386,op_ref(op,s,r))); end; LOC_REFERENCE,LOC_MEM: @@ -2525,53 +2584,140 @@ implementation tempreference:=p^.left^.location.reference; del_reference(p^.left^.location.reference); case p^.resulttype^.deftype of - orddef : begin - case porddef(p^.resulttype)^.typ of - s32bit,u32bit : - begin - emit_push_mem(tempreference); - inc(pushedparasize,4); - end; - s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, - newreference(tempreference)))); - inc(pushedparasize,2); - end; - end; + orddef : + begin + case porddef(p^.resulttype)^.typ of + s32bit,u32bit : + begin + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emit_push_mem(tempreference); end; - floatdef : begin - case pfloatdef(p^.resulttype)^.typ of - f32bit, - s32real : - begin - emit_push_mem(tempreference); - inc(pushedparasize,4); + s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : + begin + inc(pushedparasize,2); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, + newreference(tempreference),R_DI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, + R_DI,r))); + end + else + exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, + newreference(tempreference)))); + end; + end; + end; + floatdef : + begin + case pfloatdef(p^.resulttype)^.typ of + f32bit, + s32real : + begin + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emit_push_mem(tempreference); end; s64real, s64bit : begin + inc(pushedparasize,4); inc(tempreference.offset,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emit_push_mem(tempreference); + inc(pushedparasize,4); dec(tempreference.offset,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emit_push_mem(tempreference); - inc(pushedparasize,8); end; s80real : begin + inc(pushedparasize,4); inc(tempreference.offset,6); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emit_push_mem(tempreference); dec(tempreference.offset,4); + inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else emit_push_mem(tempreference); dec(tempreference.offset,2); + inc(pushedparasize,2); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, + newreference(tempreference),R_DI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, + R_DI,r))); + end + else exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, newreference(tempreference)))); - inc(pushedparasize,extended_size); end; end; end; pointerdef,procvardef, enumdef,classrefdef: begin - emit_push_mem(tempreference); inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emit_push_mem(tempreference); end; arraydef,recorddef,stringdef,setdef,objectdef : begin @@ -2579,8 +2725,14 @@ implementation if ((p^.resulttype^.deftype=setdef) and (psetdef(p^.resulttype)^.settype=smallset)) then begin - emit_push_mem(tempreference); inc(pushedparasize,4); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + concatcopy(tempreference,r^,4,false); + end + else + emit_push_mem(tempreference); end { call by value open array ? } else if (p^.resulttype^.deftype=arraydef) and @@ -2589,8 +2741,17 @@ implementation begin { first, push high } maybe_push_open_array_high; - emitpushreferenceaddr(p^.left^.location.reference); inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI))); + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emitpushreferenceaddr(p^.left^.location.reference); end else begin @@ -2607,12 +2768,22 @@ implementation if size=1 then size:=2; } { create stack space } - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); + if not inlined then + exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); inc(pushedparasize,size); { create stack reference } stackref.symbol := nil; - clear_reference(stackref); - stackref.base:=R_ESP; + if not inlined then + begin + clear_reference(stackref); + stackref.base:=R_ESP; + end + else + begin + clear_reference(stackref); + stackref.base:=procinfo.framepointer; + stackref.offset:=para_offset-pushedparasize; + end; { produce copy } if p^.resulttype^.deftype=stringdef then begin @@ -2634,9 +2805,23 @@ implementation getlabel(hlabel); inc(pushedparasize,2); emitl(A_LABEL,truelabel); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_W, + 1,r))); + end + else exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1))); emitl(A_JMP,hlabel); emitl(A_LABEL,falselabel); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_W, + 0,r))); + end + else exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,0))); emitl(A_LABEL,hlabel); end; @@ -2653,10 +2838,14 @@ implementation exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,R_AL,R_AX))); {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));} inc(pushedparasize,2); + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, + R_AX,r))); + end + else exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,R_AX))); - { this is also false !!! - if not(R_EAX in unused) then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));} if not(R_EAX in unused) then exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EDI,R_EAX))); end; @@ -2664,12 +2853,19 @@ implementation LOC_MMXREGISTER, LOC_CMMXREGISTER: begin + inc(pushedparasize,8); { was missing !!! (PM) } exprasmlist^.concat(new(pai386,op_const_reg( A_SUB,S_L,8,R_ESP))); - new(r); - reset_reference(r^); - r^.base:=R_ESP; - exprasmlist^.concat(new(pai386,op_reg_ref( + if inlined then + begin + r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO, + p^.left^.location.register,r))); + end + else + begin + r:=new_reference(R_ESP,0); + exprasmlist^.concat(new(pai386,op_reg_ref( A_MOVQ,S_NO,p^.left^.location.register,r))); end; {$endif SUPPORT_MMX} @@ -2679,7 +2875,9 @@ implementation falselabel:=oflabel; { push from right to left } if not push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right + ,inlined,para_offset + ); end; procedure secondcalln(var p : ptree); @@ -2705,7 +2903,9 @@ implementation { help reference pointer } r : preference; pp,params : ptree; + inlined : boolean; inlinecode : ptree; + para_offset : longint; { instruction for alignement correction } corr : pai386; { we must pop this size also after !! } @@ -2719,6 +2919,7 @@ implementation extended_new:=false; iolabel:=nil; inlinecode:=nil; + inlined:=false; loadesi:=true; no_virtual_call:=false; unusedregisters:=unused; @@ -2727,8 +2928,28 @@ implementation exit; if (p^.procdefinition^.options and poinline)<>0 then begin + inlined:=true; inlinecode:=p^.right; + { set it to the same lexical level } + p^.procdefinition^.parast^.symtablelevel:= + aktprocsym^.definition^.parast^.symtablelevel; + if assigned(p^.left) then + inlinecode^.para_offset:= + gettempofsizepersistant(inlinecode^.para_size); + p^.procdefinition^.parast^.call_offset:= + inlinecode^.para_offset; +{$ifdef extdebug} + Comment(V_debug, + 'inlined parasymtable is at offset ' + +tostr(p^.procdefinition^.parast^.call_offset)); + exprasmlist^.concat(new(pai_asm_comment,init( + strpnew('inlined parasymtable is at offset ' + +tostr(p^.procdefinition^.parast^.call_offset))))); +{$endif extdebug} p^.right:=nil; + { disable further inlining of the same proc + in the args } + p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); end; { only if no proc var } if not(assigned(p^.right)) then @@ -2781,25 +3002,54 @@ implementation end else {$endif test_dest_loc} - gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); + if inlined then + begin + reset_reference(funcretref); + funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.retdef^.size); + funcretref.base:=procinfo.framepointer; + end + else + gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); end; if assigned(p^.left) then begin pushedparasize:=0; { be found elsewhere } + if inlined then + para_offset:=p^.procdefinition^.parast^.call_offset+ + p^.procdefinition^.parast^.datasize + else + para_offset:=0; if assigned(p^.right) then secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1, - (p^.procdefinition^.options and poleftright)<>0) + (p^.procdefinition^.options and poleftright)<>0 + ,inlined, + para_offset + ) else secondcallparan(p^.left,p^.procdefinition^.para1, - (p^.procdefinition^.options and poleftright)<>0); + (p^.procdefinition^.options and poleftright)<>0 + ,inlined, + para_offset + ); end; params:=p^.left; p^.left:=nil; + if inlined then + inlinecode^.retoffset:=gettempofsizepersistant(4); if ret_in_param(p^.resulttype) then begin - emitpushreferenceaddr(funcretref); inc(pushedparasize,4); + if inlined then + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(funcretref),R_EDI))); + r:=new_reference(procinfo.framepointer,inlinecode^.retoffset); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,r))); + end + else + emitpushreferenceaddr(funcretref); end; { procedure variable ? } if (p^.right=nil) then @@ -3072,7 +3322,7 @@ implementation if (p^.procdefinition^.options and poexports)<>0 then Message(cg_e_dont_call_exported_direct); - if (pushedparasize mod 4)<>0 then + if (not inlined) and ((pushedparasize mod 4)<>0) then begin corr^.op1:=pointer(4-(pushedparasize mod 4)); must_pop:=true; @@ -3138,15 +3388,22 @@ implementation end; exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r))); end - else if (p^.procdefinition^.options and poinline)=0 then + else if not inlined then emitcall(p^.procdefinition^.mangledname, (p^.symtableproc^.symtabletype=unitsymtable) or ((p^.symtableproc^.symtabletype=objectsymtable) and (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))) else { inlined proc } { inlined code is in inlinecode } - secondpass(inlinecode); - if ((p^.procdefinition^.options and poclearstack)<>0) then + begin + secondpass(inlinecode); + { set poinline again } + p^.procdefinition^.options:=p^.procdefinition^.options or poinline; + { free the args } + ungetpersistanttemp(p^.procdefinition^.parast^.call_offset, + p^.procdefinition^.parast^.datasize); + end; + if (not inlined) and ((p^.procdefinition^.options and poclearstack)<>0) then begin { consider the alignment with the rest (PM) } pushedparasize:=pushedparasize+pop_size; @@ -3210,9 +3467,16 @@ implementation unused:=unusedregisters; { handle function results } - if p^.resulttype<>pdef(voiddef) then + { structured results are easy to handle.... } + { needed also when result_no_used !! } + if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then + begin + p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=funcretref; + end; + if (p^.resulttype<>pdef(voiddef)) and p^.return_value_used then begin - { a contructor could be a function with boolean result } if (p^.right=nil) and ((p^.procdefinition^.options and poconstructor)<>0) and @@ -3235,33 +3499,34 @@ implementation end; end; end - { structed results are easy to handle.... } + { structed results are easy to handle.... } else if ret_in_param(p^.resulttype) then begin - p^.location.loc:=LOC_MEM; + {p^.location.loc:=LOC_MEM; stringdispose(p^.location.reference.symbol); p^.location.reference:=funcretref; - end - else - begin - if (p^.resulttype^.deftype=orddef) then - begin - p^.location.loc:=LOC_REGISTER; - case porddef(p^.resulttype)^.typ of - s32bit,u32bit : - begin + already done above (PM) } + end + else + begin + if (p^.resulttype^.deftype=orddef) then + begin + p^.location.loc:=LOC_REGISTER; + case porddef(p^.resulttype)^.typ of + s32bit,u32bit : + begin {$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else {$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - uchar,u8bit,bool8bit,s8bit : + begin + hregister:=getregister32; + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + uchar,u8bit,bool8bit,s8bit : begin {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then @@ -3352,7 +3617,24 @@ implementation ungetiftemp(pp^.left^.location.reference); pp:=pp^.right; end; + if inlined then + ungetpersistanttemp(inlinecode^.retoffset,4); disposetree(params); + + { from now on the result can be freed normally } + if inlined and ret_in_param(p^.resulttype) then + persistanttemptonormal(funcretref.offset); + + { if return value is not used } + if (not p^.return_value_used) and (p^.resulttype<>pdef(voiddef)) then + begin + if p^.location.loc in [LOC_MEM,LOC_REFERENCE] then + { release unused temp } + ungetiftemp(p^.location.reference) + else if p^.location.loc=LOC_FPU then + { release FPU stack } + exprasmlist^.concat(new(pai386,op_none(A_FDECSTP,S_NO))); + end; end; { reverts the parameter list } @@ -3517,7 +3799,9 @@ implementation Message(parser_e_illegal_colon_qualifier); if ft=ft_typed then never_copy_const_param:=true; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); if ft=ft_typed then never_copy_const_param:=false; hp^.right:=node; @@ -3559,7 +3843,9 @@ implementation hp:=node; node:=node^.right; hp^.right:=nil; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); hp^.right:=node; if codegenerror then exit; @@ -3576,7 +3862,9 @@ implementation hp:=node; node:=node^.right; hp^.right:=nil; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); hp^.right:=node; if pararesult^.deftype<>floatdef then Message(parser_e_illegal_colon_qualifier); @@ -3741,7 +4029,9 @@ implementation { string arg } dummycoll.paratyp:=vs_var; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); if codegenerror then exit; @@ -3755,7 +4045,9 @@ implementation node^.is_colon_para then begin dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); if codegenerror then exit; hp:=node; @@ -3771,7 +4063,9 @@ implementation if hp^.is_colon_para then begin dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); if codegenerror then exit; hp:=node; @@ -3785,7 +4079,9 @@ implementation push_int(-1); { last arg longint or real } - secondcallparan(hp,@dummycoll,false); + secondcallparan(hp,@dummycoll,false + ,false,0 + ); if codegenerror then exit; @@ -4289,46 +4585,54 @@ implementation i : longint; hp : ptree; href,sref : treference; + hr : tregister; begin { this should be reimplemented for smallsets } { differently (PM) } { produce constant part } +{$ifdef TestSmallSet} + if psetdef(p^.resulttype)=smallset then + begin + smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2]; + smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1]; + {consts^.concat(new(pai_const,init_32bit(smallsetvalue)));} + hr:=getregister32; + exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L, + smallsetvalue,hr))); + hp:=p^.left; + if assigned(hp) then + begin + while assigned(hp) do + begin + secondpass(hp^.left); + if codegenerror then + exit; + case hp^.left^.location.loc of + LOC_MEM,LOC_REFERENCE : + exprasmlist^.concat(new(pai386,op_ref_reg(A_BTS,S_L, + newreference(p^.left^.location.reference),hr))); + LOC_REGISTER,LOC_CREGISTER : + exprasmlist^.concat(new(pai386,op_reg_reg(A_BTS,S_L, + p^.left^.location.register,hr))); + else + internalerror(10567); + end + hp:=hp^.right; + end; + end; + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hr; + end + else +{$endif TestSmallSet} + begin href.symbol := Nil; clear_reference(href); getlabel(l); stringdispose(p^.location.reference.symbol); href.symbol:=stringdup(constlabel2str(l,constseta)); concat_constlabel(l,constseta); - {if psetdef(p^.resulttype)=smallset then - begin - smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2]; - smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1]; - consts^.concat(new(pai_const,init_32bit(smallsetvalue))); - hp:=p^.left; - if assigned(hp) then - begin - sref.symbol:=nil; - gettempofsizereference(32,sref); - concatcopy(href,sref,32,false); - while assigned(hp) do - begin - secondpass(hp^.left); - if codegenerror then - exit; - - pushsetelement(hp^.left); - emitpushreferenceaddr(sref); - register is save in subroutine - emitcall('SET_SET_BYTE',true); - hp:=hp^.right; - end; - p^.location.reference:=sref; - end - else p^.location.reference:=href; - end - else } - begin for i:=0 to 31 do consts^.concat(new(pai_const,init_8bit(p^.constset^[i]))); hp:=p^.left; @@ -4721,22 +5025,12 @@ implementation end; {***} - procedure secondexpr(var p : ptree); - - begin - secondpass(p^.left); - if (p^.left^.resulttype<>pdef(voiddef)) then - if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then - ungetiftemp(p^.left^.location.reference); - end; - - procedure secondblockn(var p : ptree); - + procedure secondstatement(var p : ptree); var hp : ptree; begin - hp:=p^.left; + hp:=p; while assigned(hp) do begin { assignments could be distance optimized } @@ -4744,14 +5038,29 @@ implementation begin cleartempgen; secondpass(hp^.right); - if (hp^.right^.resulttype<>pdef(voiddef)) then + (* if (hp^.right^.resulttype<>pdef(voiddef)) then if hp^.right^.location.loc in [LOC_MEM,LOC_REFERENCE] then - ungetiftemp(hp^.right^.location.reference); + { release unused temp } + ungetiftemp(hp^.right^.location.reference) + else if hp^.right^.location.loc=LOC_FPU then + { release FPU stack } + exprasmlist^.concat(new(pai386,op_none(A_FDECSTP,S_NO))); + All done in secondcalln now (PM) *) end; hp:=hp^.left; end; end; + + procedure secondblockn(var p : ptree); + + begin + { do second pass on left node } + if assigned(p^.left) then + secondpass(p^.left); + end; + + procedure second_while_repeatn(var p : ptree); var @@ -4771,7 +5080,7 @@ implementation aktbreaklabel:=l2; cleartempgen; if assigned(p^.right) then - secondpass(p^.right); + secondpass(p^.right); otlabel:=truelabel; oflabel:=falselabel; @@ -5646,25 +5955,92 @@ do_jmp: end; end; - { not used for now } + { implementation not complete yet } + + var addr_correction : longint; + + procedure correct_address(p : psym); + + begin + if p^.typ=varsym then + begin + inc(pvarsym(p)^.address,addr_correction); +{$ifdef extdebug} + Comment(V_debug,pvarsym(p)^.name+' is at offset -' + +tostr(pvarsym(p)^.address)); + exprasmlist^.concat(new(pai_asm_comment,init( + strpnew(pvarsym(p)^.name+' is at offset -' + +tostr(pvarsym(p)^.address))))); +{$endif extdebug} + end; + end; procedure secondprocinline(var p : ptree); var st : psymtable; - + oldprocsym : pprocsym; + para_size : longint; + oldprocinfo : tprocinfo; + { just dummies for genentrycode } + nostackframe,make_global : boolean; + proc_names : tstringcontainer; + inlineentrycode,inlineexitcode : paasmoutput; + oldexitlabel,oldexit2label,oldquickexitlabel:Plabel; begin - st:=p^.inlineprocdef^.parast; - st^.call_offset:=4; + oldexitlabel:=aktexitlabel; + oldexit2label:=aktexit2label; + oldquickexitlabel:=quickexitlabel; + getlabel(aktexitlabel); + getlabel(aktexit2label); + oldprocsym:=aktprocsym; + oldprocinfo:=procinfo; + { set the return value } + procinfo.retdef:=p^.inlineprocdef^.retdef; + procinfo.retoffset:=p^.retoffset; + { arg space has been filled by the parent secondcall } st:=p^.inlineprocdef^.localst; - st^.call_offset:=gettempofsize(st^.datasize); + { set it to the same lexical level } + st^.symtablelevel:= + oldprocsym^.definition^.localst^.symtablelevel; + if st^.datasize>0 then + st^.call_offset:=gettempofsizepersistant(st^.datasize); +{$ifdef extdebug} + Comment(V_debug,'local symtable is at offset ' + +tostr(st^.call_offset)); + exprasmlist^.concat(new(pai_asm_comment,init( + strpnew('local symtable is at offset ' + +tostr(st^.call_offset))))); +{$endif extdebug} + addr_correction:=-st^.call_offset-st^.datasize; + st^.foreach(correct_address); +{$ifdef extdebug} exprasmlist^.concat(new(pai_asm_comment,init('Start of inlined proc'))); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBP))); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_ESP,R_EBP))); +{$endif extdebug} + { takes care of local data initialization } + inlineentrycode:=new(paasmoutput,init); + inlineexitcode:=new(paasmoutput,init); + proc_names.init; + para_size:=p^.para_size; + genentrycode(inlineentrycode,proc_names,make_global, + 0,para_size,nostackframe,true); + exprasmlist^.concatlist(inlineentrycode); secondpass(p^.left); - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EBP))); + genexitcode(inlineexitcode,0,false,true); + exprasmlist^.concatlist(inlineexitcode); +{$ifdef extdebug} exprasmlist^.concat(new(pai_asm_comment,init('End of inlined proc'))); - {we can free the local stack now } - ungettemp(st^.call_offset,st^.datasize); +{$endif extdebug} + {we can free the local data now } + if st^.datasize>0 then + ungetpersistanttemp(st^.call_offset,st^.datasize); + { set the real address again } + addr_correction:=-addr_correction; + st^.foreach(correct_address); + aktprocsym:=oldprocsym; + aktexitlabel:=oldexitlabel; + aktexit2label:=oldexit2label; + quickexitlabel:=oldquickexitlabel; + procinfo:=oldprocinfo; end; @@ -5686,7 +6062,7 @@ do_jmp: secondnot,secondinline,secondniln,seconderror, secondnothing,secondhnewn,secondhdisposen,secondnewn, secondsimplenewdispose,secondnothing,secondsetcons,secondblockn, - secondnothing,secondnothing,secondifn,secondbreakn, + secondstatement,secondnothing,secondifn,secondbreakn, secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor, secondexitn,secondwith,secondcase,secondlabel, secondgoto,secondsimplenewdispose,secondtryexcept,secondraise, @@ -5852,7 +6228,11 @@ do_jmp: dec(procinfo.framepointer_offset,4); dec(procinfo.ESI_offset,4); - dec(procinfo.retoffset,4); + { is this correct ???} + { retoffset can be negativ for results in eax !! } + { the value should be decreased only if positive } + if procinfo.retoffset>=0 then + dec(procinfo.retoffset,4); dec(procinfo.call_offset,4); aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset; @@ -5982,7 +6362,17 @@ do_jmp: end. { $Log$ - Revision 1.23 1998-05-12 10:46:58 peter + Revision 1.24 1998-05-20 09:42:33 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.23 1998/05/12 10:46:58 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/cobjects.pas b/compiler/cobjects.pas index 7ef0402cf1..5fcbab1379 100644 --- a/compiler/cobjects.pas +++ b/compiler/cobjects.pas @@ -55,9 +55,7 @@ unit cobjects; tstringitem = record data : pstring; next : pstringitem; -{$ifdef UseTokenInfo} fileinfo : tfileposinfo; { pointer to tinputfile } -{$endif UseTokenInfo} end; plinkedlist_item = ^tlinkedlist_item; @@ -144,15 +142,11 @@ unit cobjects; { inserts a string } procedure insert(const s : string); -{$ifdef UseTokenInfo} procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo); -{$endif UseTokenInfo} { gets a string } function get : string; -{$ifdef UseTokenInfo} function get_with_tokeninfo(var file_info : tfileposinfo) : string; -{$endif UseTokenInfo} { deletes all strings } procedure clear; @@ -176,7 +170,11 @@ unit cobjects; { but it's assumed, that there no seek while do_crc is true } do_crc : boolean; crc : longint; - + { temporary closing feature } + tempclosed : boolean; + tempmode : byte; + temppos : longint; + { inits a buffer with the size bufsize which is assigned to } { the file filename } constructor init(const filename : string;_bufsize : longint); @@ -216,6 +214,12 @@ unit cobjects; { closes the file and releases the buffer } procedure close; +{$ifdef TEST_TEMPCLOSE} + { temporary closing } + procedure tempclose; + procedure tempreopen; +{$endif TEST_TEMPCLOSE} + { goto the given position } procedure seek(l : longint); @@ -479,7 +483,6 @@ end; last:=hp; end; -{$ifdef UseTokenInfo} procedure tstringcontainer.insert_with_tokeninfo (const s : string; const file_info : tfileposinfo); @@ -505,7 +508,6 @@ end; last:=hp; end; -{$endif UseTokenInfo} procedure tstringcontainer.clear; var @@ -542,7 +544,6 @@ end; end; end; -{$ifdef UseTokenInfo} function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string; var @@ -566,7 +567,6 @@ end; dispose(hp); end; end; -{$endif UseTokenInfo} {**************************************************************************** TLINKEDLIST_ITEM @@ -807,6 +807,7 @@ end; buflast:=0; do_crc:=false; iomode:=0; + tempclosed:=false; change_endian:=false; clear_crc; end; @@ -994,8 +995,11 @@ end; begin if bufpos+length(s)>bufsize then flush; + { why is there not CRC here ??? } move(s[1],(buf+bufpos)^,length(s)); inc(bufpos,length(s)); + { should be + write_data(s[1],length(s)); } end; procedure tbufferedfile.write_pchar(p : pchar); @@ -1007,10 +1011,13 @@ end; l:=strlen(p); if l>=bufsize then runerror(222); + { why is there not CRC here ???} if bufpos+l>bufsize then flush; move(p^,(buf+bufpos)^,l); inc(bufpos,l); + { should be + write_data(p^,l); } end; procedure tbufferedfile.write_byte(b : byte); @@ -1071,14 +1078,67 @@ end; flush; system.close(f); freemem(buf,bufsize); + buf:=nil; iomode:=0; end; end; +{$ifdef TEST_TEMPCLOSE} + procedure tbufferedfile.tempclose; + + begin + if iomode<>0 then + begin + temppos:=system.filepos(f); + tempmode:=iomode; + tempclosed:=true; + system.close(f); + iomode:=0; + end + else + tempclosed:=false; + end; + + procedure tbufferedfile.tempreopen; + + var + ofm : byte; + + begin + if tempclosed then + begin + if tempmode=1 then + begin + ofm:=filemode; + iomode:=1; + filemode:=0; + system.reset(f,1); + filemode:=ofm; + end + else if tempmode=2 then + begin + iomode:=2; + system.rewrite(f,1); + end; + system.seek(f,temppos); + end; + end; +{$endif TEST_TEMPCLOSE} + end. { $Log$ - Revision 1.7 1998-05-06 18:36:53 peter + Revision 1.8 1998-05-20 09:42:33 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.7 1998/05/06 18:36:53 peter * tai_section extended with code,data,bss sections and enumerated type * ident 'compiled by FPC' moved to pmodules * small fix for smartlink diff --git a/compiler/files.pas b/compiler/files.pas index 5ffc020a51..444bc9109d 100644 --- a/compiler/files.pas +++ b/compiler/files.pas @@ -102,6 +102,7 @@ unit files; map : punitmap; { mapping of all used units } unitcount : word; { local unit counter } + unit_index : word; { global counter for browser } symtable : pointer; { pointer to the psymtable of this unit } output_format : tof; { how to write this file } @@ -219,6 +220,7 @@ unit files; var main_module : pmodule; current_module : pmodule; + global_unit_count : word; loaded_units : tlinkedlist; @@ -300,11 +302,21 @@ unit files; dispose(hp,done); hp:=files; end; + last_ref_index:=0; end; procedure tfilemanager.close_all; + var + hp : pextfile; + begin + hp:=files; + while assigned(hp) do + begin + hp^.close; + hp:=hp^._next; + end; end; procedure tfilemanager.register_file(f : pextfile); @@ -420,6 +432,12 @@ unit files; 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 } @@ -849,6 +867,8 @@ unit files; flags:=0; crc:=0; unitcount:=1; + inc(global_unit_count); + unit_index:=global_unit_count; do_assemble:=false; do_compile:=false; sources_avail:=true; @@ -909,7 +929,17 @@ unit files; end. { $Log$ - Revision 1.11 1998-05-12 10:46:59 peter + Revision 1.12 1998-05-20 09:42:33 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.11 1998/05/12 10:46:59 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/hcodegen.pas b/compiler/hcodegen.pas index bdc05496b0..232f848504 100644 --- a/compiler/hcodegen.pas +++ b/compiler/hcodegen.pas @@ -50,6 +50,8 @@ unit hcodegen; _class : pobjectdef; { return type } retdef : pdef; + { the definition of the proc itself } + def : pdef; { frame pointer offset } framepointer_offset : longint; { self pointer offset } @@ -140,14 +142,15 @@ unit hcodegen; { convert/concats a label for constants in the consts section } - function constlabel2str(p:plabel;ctype:tconsttype):string; + function constlabel2str(l : plabel;ctype:tconsttype):string; + function constlabelnb2str(pnb : longint;ctype:tconsttype):string; procedure concat_constlabel(p:plabel;ctype:tconsttype); implementation uses - cobjects,globals,files,strings; + systems,cobjects,globals,files,strings; {***************************************************************************** initialize/terminate the codegen for procedure and modules @@ -353,12 +356,22 @@ implementation consttypestr : array[tconsttype] of string[6]= ('ord','string','real','bool','int','char','set'); - function constlabel2str(p:plabel;ctype:tconsttype):string; + { Peter this gives problems for my inlines !! } + { we must use the number directly !!! (PM) } + function constlabel2str(l : plabel;ctype:tconsttype):string; begin if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then - constlabel2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(p^.nb) + constlabel2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(l^.nb) else - constlabel2str:=lab2str(p); + constlabel2str:=lab2str(l); + end; + + function constlabelnb2str(pnb : longint;ctype:tconsttype):string; + begin + if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then + constlabelnb2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(pnb) + else + constlabelnb2str:=target_asm.labelprefix+tostr(pnb); end; @@ -385,7 +398,17 @@ end. { $Log$ - Revision 1.4 1998-05-07 00:17:01 peter + Revision 1.5 1998-05-20 09:42:34 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.4 1998/05/07 00:17:01 peter * smartlinking for sets + consts labels are now concated/generated in hcodegen * moved some cpu code to cga and some none cpu depended code from cga diff --git a/compiler/i386.pas b/compiler/i386.pas index fa9738f2a2..9e742e9e0d 100644 --- a/compiler/i386.pas +++ b/compiler/i386.pas @@ -315,7 +315,8 @@ unit i386; { resets all values of ref to defaults } procedure reset_reference(var ref : treference); - + { mostly set value of a reference } + function new_reference(base : tregister;offset : longint) : preference; { same as reset_reference, but symbol is disposed } { use this only for already used references } procedure clear_reference(var ref : treference); @@ -1179,7 +1180,19 @@ unit i386; {$endif} end; - procedure clear_reference(var ref : treference); + function new_reference(base : tregister;offset : longint) : preference; + + var + r : preference; + begin + new(r); + reset_reference(r^); + r^.base:=base; + r^.offset:=offset; + new_reference:=r; + end; + + procedure clear_reference(var ref : treference); begin stringdispose(ref.symbol); @@ -1780,7 +1793,17 @@ unit i386; end. { $Log$ - Revision 1.6 1998-05-04 17:54:25 peter + Revision 1.7 1998-05-20 09:42:34 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.6 1998/05/04 17:54:25 peter + smartlinking works (only case jumptable left todo) * redesign of systems.pas to support assemblers and linkers + Unitname is now also in the PPU-file, increased version to 14 diff --git a/compiler/parser.pas b/compiler/parser.pas index 3b15b0a439..a9fcd6e3fa 100644 --- a/compiler/parser.pas +++ b/compiler/parser.pas @@ -123,9 +123,7 @@ unit parser; { some variables to save the compiler state } oldtoken : ttoken; -{$ifdef UseTokenInfo} oldtokenpos : tfileposinfo; -{$endif UseTokenInfo} oldpattern : stringid; oldpreprocstack : ppreprocstack; @@ -237,9 +235,7 @@ unit parser; oldmacros:=macros; oldpattern:=pattern; oldtoken:=token; -{$ifdef UseTokenInfo} oldtokenpos:=tokenpos; -{$endif UseTokenInfo} oldorgpattern:=orgpattern; old_block_type:=block_type; oldpreprocstack:=preprocstack; @@ -284,7 +280,7 @@ unit parser; { init code generator for a new module } codegen_newmodule; macros:=new(psymtable,init(macrosymtable)); - + macros^.name:=stringdup('Conditionals for '+filename); define_macros; { startup scanner } @@ -306,7 +302,6 @@ unit parser; { global switches are read, so further changes aren't allowed } current_module^.in_main:=true; - { open assembler response } if (compile_level=1) then AsmRes.Init('ppas'); @@ -320,6 +315,7 @@ unit parser; } hp:=loadunit(upper(target_info.system_unit),true,true); systemunit:=hp^.symtable; + make_ref:=false; readconstdefs; { we could try to overload caret by default } symtablestack:=systemunit; @@ -328,6 +324,7 @@ unit parser; if assigned(srsym) and (srsym^.typ=procsym) and (overloaded_operators[STARSTAR]=nil) then overloaded_operators[STARSTAR]:=pprocsym(srsym); + make_ref:=true; end else begin @@ -364,6 +361,7 @@ unit parser; systemunit:=nil; end; registerdef:=true; + make_ref:=true; { current return type is void } procinfo.retdef:=voiddef; @@ -447,16 +445,16 @@ done: procprefix:=oldprocprefix; { close the inputfiles } -{$ifndef UseBrowser} - { but not if we want the names for the browser ! } +{$ifdef UseBrowser} + { we need the names for the browser ! } + current_module^.sourcefiles.close_all; +{$else UseBrowser} current_module^.sourcefiles.done; {$endif not UseBrowser} { restore scanner state } pattern:=oldpattern; token:=oldtoken; -{$ifdef UseTokenInfo} tokenpos:=oldtokenpos; -{$endif UseTokenInfo} orgpattern:=oldorgpattern; block_type:=old_block_type; @@ -508,7 +506,17 @@ done: end. { $Log$ - Revision 1.16 1998-05-12 10:47:00 peter + Revision 1.17 1998-05-20 09:42:34 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.16 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/pass_1.pas b/compiler/pass_1.pas index 3d93092b62..95c25d1a5c 100644 --- a/compiler/pass_1.pas +++ b/compiler/pass_1.pas @@ -35,7 +35,7 @@ unit pass_1; implementation uses - cobjects,verbose,systems,globals,aasm,symtable, + scanner,cobjects,verbose,systems,globals,aasm,symtable, types,strings,hcodegen,files {$ifdef i386} ,i386 @@ -125,16 +125,20 @@ unit pass_1; end; - { calculates the needed registers for a binary operator } - procedure calcregisters(p : ptree;r32,fpu,mmx : word); - + procedure left_right_max(p : ptree); begin p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); {$ifdef SUPPORT_MMX} p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); {$endif SUPPORT_MMX} + end; + { calculates the needed registers for a binary operator } + procedure calcregisters(p : ptree;r32,fpu,mmx : word); + + begin + left_right_max(p); { Nur wenn links und rechts ein Unterschied < ben”tige Anzahl ist, } { wird ein zus„tzliches Register ben”tigt, da es dann keinen } { schwierigeren Ast gibt, welcher erst ausgewertet werden kann } @@ -164,7 +168,8 @@ unit pass_1; end; function isconvertable(def_from,def_to : pdef; - var doconv : tconverttype;fromtreetype : ttreetyp) : boolean; + var doconv : tconverttype;fromtreetype : ttreetyp; + explicit : boolean) : boolean; { from_is_cstring muá true sein, wenn def_from die Definition einer } { Stringkonstanten ist, n”tig wegen der Konvertierung von String- } @@ -260,7 +265,9 @@ unit pass_1; doconv:=tc_real_2_real; { comp isn't a floating type } {$ifdef i386} - if (pfloatdef(def_to)^.typ=s64bit) then + if (pfloatdef(def_to)^.typ=s64bit) and + (pfloatdef(def_from)^.typ<>s64bit) and + not (explicit) then Message(parser_w_convert_real_2_comp); {$endif} end; @@ -1356,13 +1363,7 @@ unit pass_1; if codegenerror then exit; - p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); - p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); -{$ifdef SUPPORT_MMX} - p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); -{$endif SUPPORT_MMX} - if p^.registers32<2 then p^.registers32:=2; - + left_right_max(p); p^.resulttype:=s32bitdef; p^.location.loc:=LOC_REGISTER; end; @@ -1887,7 +1888,7 @@ unit pass_1; Message(cg_e_upper_lower_than_lower); { both types must be compatible } if not(isconvertable(p^.left^.resulttype,p^.right^.resulttype, - ct,ordconstn)) and + ct,ordconstn,false)) and not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) then Message(sym_e_type_mismatch); end; @@ -1910,7 +1911,7 @@ unit pass_1; begin if not(isconvertable(p^.right^.resulttype, parraydef(p^.left^.resulttype)^.rangedef, - ct,ordconstn)) and + ct,ordconstn,false)) and not(is_equal(p^.right^.resulttype, parraydef(p^.left^.resulttype)^.rangedef)) then Message(sym_e_type_mismatch); @@ -2306,7 +2307,8 @@ unit pass_1; p^.registersmmx:=p^.left^.registersmmx; {$endif} set_location(p^.location,p^.left^.location); - if (not(isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype))) then + if (not(isconvertable(p^.left^.resulttype,p^.resulttype, + p^.convtyp,p^.left^.treetype,p^.explizit))) then begin if is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then begin @@ -2431,7 +2433,8 @@ unit pass_1; end else begin - if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn { nur Dummy} ) then + if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp, + ordconstn { nur Dummy},false ) then Message(cg_e_illegal_type_conversion); end; @@ -2451,7 +2454,8 @@ unit pass_1; end else begin - if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn { nur Dummy} ) then + if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp, + ordconstn { nur Dummy},false ) then Message(cg_e_illegal_type_conversion); end; end @@ -2472,7 +2476,8 @@ unit pass_1; begin { this is wrong because it converts to a 4 byte long var !! if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then } - if not isconvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn { nur Dummy} ) then + if not isconvertable(p^.left^.resulttype,u8bitdef, + p^.convtyp,ordconstn { nur Dummy},false ) then Message(cg_e_illegal_type_conversion); end; end @@ -2567,7 +2572,8 @@ unit pass_1; must_be_valid:=false; { here we must add something for the implicit type } { conversion from array of char to pchar } - if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then + if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp, + p^.left^.treetype,false) then if convtyp=tc_array_to_pointer then must_be_valid:=false; firstpass(p^.left); @@ -2657,10 +2663,11 @@ unit pass_1; pd : pprocdef; actprocsym : pprocsym; def_from,def_to,conv_to : pdef; - pt : ptree; - exactmatch : boolean; + pt,inlinecode : ptree; + exactmatch,inlined : boolean; paralength,l : longint; pdc : pdefcoll; + curtokenpos : tfileposinfo; { only Dummy } hcvt : tconverttype; @@ -2696,10 +2703,19 @@ unit pass_1; store_valid:=must_be_valid; must_be_valid:=false; + inlined:=false; + if assigned(p^.procdefinition) and + ((p^.procdefinition^.options and poinline)<>0) then + begin + inlinecode:=p^.right; + if assigned(inlinecode) then + begin + inlined:=true; + p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); + end; + p^.right:=nil; + end; { procedure variable ? } - { right contains inline code for inlined procedures } - if (not assigned(p^.procdefinition)) or - ((p^.procdefinition^.options and poinline)=0) then if assigned(p^.right) then begin { procedure does a call } @@ -2887,7 +2903,8 @@ unit pass_1; begin { erst am Anfang } while (assigned(procs)) and - not(isconvertable(pt^.resulttype,procs^.nextpara^.data,hcvt,pt^.left^.treetype)) do + not(isconvertable(pt^.resulttype,procs^.nextpara^.data, + hcvt,pt^.left^.treetype,false)) do begin hp:=procs^.next; dispose(procs); @@ -2898,7 +2915,7 @@ unit pass_1; while (assigned(hp)) and assigned(hp^.next) do begin if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data, - hcvt,pt^.left^.treetype)) then + hcvt,pt^.left^.treetype,false)) then begin hp2:=hp^.next^.next; dispose(hp^.next); @@ -3077,7 +3094,11 @@ unit pass_1; end; {$endif CHAINPROCSYMS} {$ifdef UseBrowser} - add_new_ref(procs^.data^.lastref); + if make_ref then + begin + get_cur_file_pos(curtokenpos); + add_new_ref(procs^.data^.lastref,@curtokenpos); + end; {$endif UseBrowser} p^.procdefinition:=procs^.data; @@ -3100,14 +3121,6 @@ unit pass_1; {$endif CHAINPROCSYMS} end;{ end of procedure to call determination } - { work trough all parameters to insert the type conversions } - if assigned(p^.left) then - begin - old_count_ref:=count_ref; - count_ref:=true; - firstcallparan(p^.left,p^.procdefinition^.para1); - count_ref:=old_count_ref; - end; { handle predefined procedures } if (p^.procdefinition^.options and pointernproc)<>0 then begin @@ -3135,6 +3148,7 @@ unit pass_1; end else { no intern procedure => we do a call } + { calc the correture value for the register } { handle predefined procedures } if (p^.procdefinition^.options and poinline)<>0 then begin @@ -3146,16 +3160,32 @@ unit pass_1; if not assigned(p^.right) then begin if assigned(p^.procdefinition^.code) then - p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code)) + inlinecode:=genprocinlinenode(p,ptree(p^.procdefinition^.code)) else comment(v_fatal,'no code for inline procedure stored'); - firstpass(p^.right); + if assigned(inlinecode) then + begin + firstpass(inlinecode); + { consider it has not inlined if called + again inside the args } + p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); + inlined:=true; + end; + end; end else procinfo.flags:=procinfo.flags or pi_do_call; - { calc the correture value for the register } + { work trough all parameters to insert the type conversions } + { !!! done now after internproc !! (PM) } + if assigned(p^.left) then + begin + old_count_ref:=count_ref; + count_ref:=true; + firstcallparan(p^.left,p^.procdefinition^.para1); + count_ref:=old_count_ref; + end; {$ifdef i386} for regi:=R_EAX to R_EDI do begin @@ -3246,6 +3276,11 @@ unit pass_1; end; end; + if inlined then + begin + p^.right:=inlinecode; + p^.procdefinition^.options:=p^.procdefinition^.options or poinline; + end; { determine the registers of the procedure variable } { is this OK for inlined procs also ?? (PM) } if assigned(p^.right) then @@ -3301,7 +3336,7 @@ unit pass_1; var hp,hpp : ptree; - isreal,store_valid,file_is_typed : boolean; + store_count_ref,isreal,store_valid,file_is_typed : boolean; procedure do_lowhigh(adef : pdef); @@ -3336,9 +3371,16 @@ unit pass_1; end; begin + store_valid:=must_be_valid; + store_count_ref:=count_ref; + count_ref:=false; { if we handle writeln; p^.left contains no valid address } if assigned(p^.left) then begin + if p^.left^.treetype=callparan then + firstcallparan(p^.left,nil) + else + firstpass(p^.left); p^.registers32:=p^.left^.registers32; p^.registersfpu:=p^.left^.registersfpu; {$ifdef SUPPORT_MMX} @@ -3346,7 +3388,6 @@ unit pass_1; {$endif SUPPORT_MMX} set_location(p^.location,p^.left^.location); end; - store_valid:=must_be_valid; if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x, in_typeof_x,in_ord_x, in_reset_typedfile,in_rewrite_typedfile]) then @@ -3492,9 +3533,8 @@ unit pass_1; (penumdef(p^.resulttype)^.has_jumps) then begin Message(parser_e_succ_and_pred_enums_with_assign_not_possible); - exit; - end; - if p^.left^.treetype=ordconstn then + end + else if p^.left^.treetype=ordconstn then begin if p^.inlinenumber=in_pred_x then hp:=genordinalconstnode(p^.left^.value+1, @@ -3840,6 +3880,7 @@ unit pass_1; else internalerror(8); end; must_be_valid:=store_valid; + count_ref:=store_count_ref; end; procedure firstsubscriptn(var p : ptree); @@ -4021,11 +4062,7 @@ unit pass_1; if codegenerror then exit; - p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); - p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); -{$ifdef SUPPORT_MMX} - p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); -{$endif SUPPORT_MMX} + left_right_max(p); { this is not allways true due to optimization } { but if we don't set this we get problems with optimizing self code } if psetdef(p^.right^.resulttype)^.settype<>smallset then @@ -4053,6 +4090,7 @@ unit pass_1; {$ifdef SUPPORT_MMX} p^.registersmmx:=p^.right^.registersmmx; {$endif SUPPORT_MMX} + { left is the next in the list } firstpass(p^.left); if codegenerror then exit; @@ -4534,11 +4572,7 @@ unit pass_1; if codegenerror then exit; - p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); - p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); -{$ifdef SUPPORT_MMX} - p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); -{$endif SUPPORT_MMX} + left_right_max(p); { left must be a class } if (p^.left^.resulttype^.deftype<>objectdef) or @@ -4567,11 +4601,13 @@ unit pass_1; if codegenerror then exit; + left_right_max(p); +(* this was wrong,no ?? p^.registersfpu:=max(p^.left^.registersfpu,p^.left^.registersfpu); p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); {$ifdef SUPPORT_MMX} p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); -{$endif SUPPORT_MMX} +{$endif SUPPORT_MMX} *) { left must be a class } if (p^.left^.resulttype^.deftype<>objectdef) or @@ -4626,14 +4662,7 @@ unit pass_1; firstpass(p^.right); p^.right:=gentypeconvnode(p^.right,s32bitdef); firstpass(p^.right); - p^.registersfpu:=max(p^.left^.registersfpu, - p^.right^.registersfpu); - p^.registers32:=max(p^.left^.registers32, - p^.right^.registers32); -{$ifdef SUPPORT_MMX} - p^.registersmmx:=max(p^.left^.registersmmx, - p^.right^.registersmmx); -{$endif SUPPORT_MMX} + left_right_max(p); end; end; end; @@ -4652,14 +4681,7 @@ unit pass_1; if codegenerror then exit; - p^.registers32:=max(p^.left^.registers32, - p^.right^.registers32); - p^.registersfpu:=max(p^.left^.registersfpu, - p^.right^.registersfpu); -{$ifdef SUPPORT_MMX} - p^.registersmmx:=max(p^.left^.registersmmx, - p^.right^.registersmmx); -{$endif SUPPORT_MMX} + left_right_max(p); p^.resulttype:=voiddef; end else @@ -4838,7 +4860,7 @@ unit pass_1; begin comment(v_debug,'tree changed after first counting pass ' +tostr(longint(p^.treetype))); - compare_trees(p,oldp); + compare_trees(oldp,p); end; dispose(oldp); end; @@ -4872,7 +4894,17 @@ unit pass_1; end. { $Log$ - Revision 1.18 1998-05-11 13:07:55 peter + Revision 1.19 1998-05-20 09:42:34 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.18 1998/05/11 13:07:55 peter + $ifdef NEWPPU for the new ppuformat + $define GDB not longer required * removed all warnings and stripped some log comments diff --git a/compiler/pbase.pas b/compiler/pbase.pas index 065b8a0b78..7e837aca8a 100644 --- a/compiler/pbase.pas +++ b/compiler/pbase.pas @@ -94,7 +94,7 @@ unit pbase; uses - files,scanner,symtable,systems,verbose; + files,scanner,systems,verbose; { consumes token i, if the current token is unequal i } { a syntax error is written } @@ -148,11 +148,7 @@ unit pbase; else begin if token=_END then -{$ifdef UseTokenInfo} last_endtoken_filepos:=tokenpos; -{$else UseTokenInfo} - get_cur_file_pos(last_endtoken_filepos); -{$endif UseTokenInfo} token:=yylex; end; end; @@ -160,19 +156,11 @@ unit pbase; procedure consume_all_until(atoken : ttoken); begin -{$ifndef UseTokenInfo} while (token<>atoken) and (token<>_EOF) do consume(token); { this will create an error if the token is _EOF } if token<>atoken then consume(atoken); -{$else UseTokenInfo} - while (token<>atoken) and (token<>_EOF) do - consume(token); - { this will create an error if the token is _EOF } - if token<>atoken then - consume(atoken); -{$endif UseTokenInfo} { this error is fatal as we have read the whole file } Message(scan_f_end_of_file); end; @@ -193,12 +181,8 @@ unit pbase; begin sc:=new(pstringcontainer,init); repeat -{$ifndef UseTokenInfo} - sc^.insert(pattern); -{$else UseTokenInfo} sc^.insert_with_tokeninfo(pattern, tokenpos); -{$endif UseTokenInfo} consume(ID); if token=COMMA then consume(COMMA) else break @@ -212,27 +196,17 @@ unit pbase; var s : string; -{$ifdef UseTokenInfo} filepos : tfileposinfo; ss : pvarsym; -{$endif UseTokenInfo} begin -{$ifdef UseTokenInfo} s:=sc^.get_with_tokeninfo(filepos); -{$else UseTokenInfo} - s:=sc^.get; -{$endif UseTokenInfo} while s<>'' do begin -{$ifndef UseTokenInfo} - st^.insert(new(pvarsym,init(s,def))); -{$else UseTokenInfo} ss:=new(pvarsym,init(s,def)); ss^.line_no:=filepos.line; st^.insert(ss); -{$endif UseTokenInfo} { static data fields are inserted in the globalsymtable } if (st^.symtabletype=objectsymtable) and ((current_object_option and sp_static)<>0) then @@ -240,11 +214,7 @@ unit pbase; s:=lowercase(st^.name^)+'_'+s; st^.defowner^.owner^.insert(new(pvarsym,init(s,def))); end; -{$ifdef UseTokenInfo} s:=sc^.get_with_tokeninfo(filepos); -{$else UseTokenInfo} - s:=sc^.get; -{$endif UseTokenInfo} end; dispose(sc,done); end; @@ -253,7 +223,17 @@ end. { $Log$ - Revision 1.6 1998-05-12 10:47:00 peter + Revision 1.7 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.6 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 84c70140b1..82a77b050f 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -201,7 +201,7 @@ unit pdecl; {$ifndef GDB} else d:=new(pstringdef,init(255)); {$else GDB} - else d:=globaldef('SYSTEM.STRING'); + else d:=globaldef('STRING'); {$endif GDB} {$else UseAnsiString} if p^.value>255 then @@ -211,18 +211,18 @@ unit pdecl; {$ifndef GDB} else d:=new(pstringdef,init(255)); {$else GDB} - else d:=globaldef('SYSTEM.STRING'); + else d:=globaldef('STRING'); {$endif GDB} consume(RECKKLAMMER); {$endif UseAnsiString} disposetree(p); end - { should string bwithout suffix be an ansistring also + { should string without suffix be an ansistring also in ansistring mode ?? (PM) } {$ifndef GDB} else d:=new(pstringdef,init(255)); {$else GDB} - else d:=globaldef('SYSTEM.STRING'); + else d:=globaldef('STRING'); {$endif GDB} stringtype:=d; end; @@ -382,9 +382,7 @@ unit pdecl; sc : pstringcontainer; hp : pdef; s : string; -{$ifdef UseTokenInfo} filepos : tfileposinfo; -{$endif UseTokenInfo} pp : pprocdef; begin @@ -442,7 +440,7 @@ unit pdecl; end else hp:=new(pformaldef,init); - s:=sc^.get; + s:=sc^.get_with_tokeninfo(filepos); while s<>'' do begin new(hp2); @@ -450,7 +448,7 @@ unit pdecl; hp2^.data:=hp; hp2^.next:=propertyparas; propertyparas:=hp2; - s:=sc^.get; + s:=sc^.get_with_tokeninfo(filepos); end; dispose(sc,done); if token=SEMICOLON then consume(SEMICOLON) @@ -1546,9 +1544,7 @@ unit pdecl; old_block_type : tblock_type; { to handle absolute } abssym : pabsolutesym; -{$ifdef UseTokenInfo} filepos : tfileposinfo; -{$endif UseTokenInfo} begin @@ -1566,11 +1562,7 @@ unit pdecl; p:=read_type(''); if do_absolute and (token=ID) and (pattern='ABSOLUTE') then begin -{$ifdef UseTokenInfo} - s:=sc^.get_with_tokeninfo(filepos); -{$else UseTokenInfo} - s:=sc^.get; -{$endif UseTokenInfo} + s:=sc^.get_with_tokeninfo(filepos); if sc^.get<>'' then Message(parser_e_absolute_only_one_var); dispose(sc,done); @@ -1586,9 +1578,7 @@ unit pdecl; abssym^.typ:=absolutesym; abssym^.abstyp:=tovar; abssym^.ref:=srsym; -{$ifdef UseTokenInfo} abssym^.line_no:=filepos.line; -{$endif UseTokenInfo} symtablestack^.insert(abssym); end else @@ -1600,9 +1590,7 @@ unit pdecl; abssym^.typ:=absolutesym; abssym^.abstyp:=toasm; abssym^.asmname:=stringdup(s); -{$ifdef UseTokenInfo} abssym^.line_no:=filepos.line; -{$endif UseTokenInfo} symtablestack^.insert(abssym); end else @@ -1615,9 +1603,7 @@ unit pdecl; abssym^.typ:=absolutesym; abssym^.abstyp:=toaddr; abssym^.absseg:=false; -{$ifdef UseTokenInfo} abssym^.line_no:=filepos.line; -{$endif UseTokenInfo} s:=pattern; consume(INTCONST); val(s,abssym^.address,code); @@ -1787,7 +1773,17 @@ unit pdecl; end. { $Log$ - Revision 1.17 1998-05-11 13:07:55 peter + Revision 1.18 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.17 1998/05/11 13:07:55 peter + $ifdef NEWPPU for the new ppuformat + $define GDB not longer required * removed all warnings and stripped some log comments diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 9b502e6500..9985fadfee 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -654,13 +654,10 @@ unit pexpr; d : bestreal; constset : pconstset; propsym : ppropertysym; -{$ifdef UseTokenInfo} oldp1 : ptree; filepos : tfileposinfo; -{$endif UseTokenInfo} -{$ifdef UseTokenInfo} procedure check_tokenpos; begin if (p1<>oldp1) then @@ -671,15 +668,12 @@ unit pexpr; filepos:=tokenpos; end; end; -{$endif UseTokenInfo} { p1 and p2 must contain valid values } procedure postfixoperators; begin -{$ifdef UseTokenInfo} check_tokenpos; -{$endif UseTokenInfo} while again do begin case token of @@ -904,9 +898,7 @@ unit pexpr; else again:=false; end; end; -{$ifdef UseTokenInfo} check_tokenpos; -{$endif UseTokenInfo} end; end; @@ -930,10 +922,8 @@ unit pexpr; possible_error : boolean; begin -{$ifdef UseTokenInfo} oldp1:=nil; filepos:=tokenpos; -{$endif UseTokenInfo} case token of ID: begin @@ -954,7 +944,14 @@ unit pexpr; end else begin - getsym(pattern,true); + if lastsymknown then + begin + srsym:=lastsrsym; + srsymtable:=lastsrsymtable; + lastsymknown:=false; + end + else + getsym(pattern,true); consume(ID); { is this an access to a function result ? } if assigned(aktprocsym) and @@ -1516,9 +1513,7 @@ unit pexpr; end; end; factor:=p1; -{$ifdef UseTokenInfo} check_tokenpos; -{$endif UseTokenInfo} end; type Toperator_precedence=(opcompare,opaddition,opmultiply); @@ -1556,9 +1551,7 @@ unit pexpr; var p1,p2:Ptree; oldt:Ttoken; -{$ifdef UseTokenInfo} filepos : tfileposinfo; -{$endif UseTokenInfo} begin @@ -1574,9 +1567,7 @@ unit pexpr; ((token<>EQUAL) or accept_equal) then begin oldt:=token; -{$ifdef UseTokenInfo} filepos:=tokenpos; -{$endif UseTokenInfo} consume(token); { if pred_level=high(Toperator_precedence) then } @@ -1585,9 +1576,7 @@ unit pexpr; else p2:=sub_expr(succ(pred_level),true); p1:=gennode(tok2node[oldt],p1,p2); -{$ifdef UseTokenInfo} set_tree_filepos(p1,filepos); -{$endif UseTokenInfo} end else @@ -1613,20 +1602,16 @@ unit pexpr; var p1,p2 : ptree; oldafterassignment : boolean; -{$ifdef UseTokenInfo} oldp1 : ptree; filepos : tfileposinfo; -{$endif UseTokenInfo} begin oldafterassignment:=afterassignment; p1:=sub_expr(opcompare,true); if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then afterassignment:=true; -{$ifdef UseTokenInfo} filepos:=tokenpos; oldp1:=p1; -{$endif UseTokenInfo} case token of POINTPOINT : begin consume(POINTPOINT); @@ -1679,10 +1664,8 @@ unit pexpr; end; end; afterassignment:=oldafterassignment; -{$ifdef UseTokenInfo} if p1<>oldp1 then set_tree_filepos(p1,filepos); -{$endif UseTokenInfo} expr:=p1; end; @@ -1732,7 +1715,17 @@ unit pexpr; end. { $Log$ - Revision 1.14 1998-05-11 13:07:56 peter + Revision 1.15 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.14 1998/05/11 13:07:56 peter + $ifdef NEWPPU for the new ppuformat + $define GDB not longer required * removed all warnings and stripped some log comments diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index 4887a6f1bb..103b04deaa 100644 --- a/compiler/pmodules.pas +++ b/compiler/pmodules.pas @@ -274,7 +274,7 @@ unit pmodules; insertinternsyms(p); end; - procedure load_ppu(hp : pmodule;compile_system : boolean); + procedure load_ppu(oldhp,hp : pmodule;compile_system : boolean); var loaded_unit : pmodule; @@ -322,7 +322,17 @@ unit pmodules; if not(hp^.sources_avail) then Message1(unit_f_cant_compile_unit,hp^.unitname^) else - compile(hp^.mainsource^,compile_system); + begin +{$ifdef TEST_TEMPCLOSE} + if assigned(oldhp^.current_inputfile) then + oldhp^.current_inputfile^.tempclose; +{$endif TEST_TEMPCLOSE} + compile(hp^.mainsource^,compile_system); +{$ifdef TEST_TEMPCLOSE} + if not oldhp^.compiled then + oldhp^.current_inputfile^.tempreopen; +{$endif TEST_TEMPCLOSE} + end; exit; end; @@ -336,8 +346,10 @@ unit pmodules; hp^.symtable:=new(punitsymtable,load(hp^.unitname^)); { if this is the system unit insert the intern symbols } + make_ref:=false; if compile_system then insertinternsyms(psymtable(hp^.symtable)); + make_ref:=true; end; { now only read the implementation part } @@ -389,7 +401,17 @@ unit pmodules; if not(hp^.sources_avail) then Message1(unit_f_cant_compile_unit,hp^.unitname^) else - compile(hp^.mainsource^,compile_system); + begin +{$ifdef TEST_TEMPCLOSE} + if assigned(oldhp^.current_inputfile) then + oldhp^.current_inputfile^.tempclose; +{$endif TEST_TEMPCLOSE} + compile(hp^.mainsource^,compile_system); +{$ifdef TEST_TEMPCLOSE} + if not oldhp^.compiled then + oldhp^.current_inputfile^.tempreopen; +{$endif TEST_TEMPCLOSE} + end; exit; end; { setup the map entry for deref } @@ -407,8 +429,10 @@ unit pmodules; { if this is the system unit insert the intern } { symbols } + make_ref:=false; if compile_system then insertinternsyms(psymtable(hp^.symtable)); + make_ref:=true; { now only read the implementation part } hp^.in_implementation:=true; @@ -443,7 +467,15 @@ unit pmodules; if not(hp^.sources_avail) then Message1(unit_f_cant_compile_unit,hp^.unitname^) else - compile(hp^.mainsource^,compile_system); + begin +{ifdef TEST_TEMPCLOSE} + oldhp^.current_inputfile^.tempclose; +{endif TEST_TEMPCLOSE} + compile(hp^.mainsource^,compile_system); +{ifdef TEST_TEMPCLOSE} + oldhp^.current_inputfile^.tempclose; +{endif TEST_TEMPCLOSE} + end; exit; end; *) { read until ibend } @@ -514,7 +546,17 @@ unit pmodules; if not(hp^.sources_avail) then Message1(unit_f_cant_compile_unit,hp^.unitname^) else - compile(hp^.mainsource^,compile_system); + begin +{$ifdef TEST_TEMPCLOSE} + if assigned(old_current_module^.current_inputfile) then + old_current_module^.current_inputfile^.tempclose; +{$endif TEST_TEMPCLOSE} + compile(hp^.mainsource^,compile_system); +{$ifdef TEST_TEMPCLOSE} + if not old_current_module^.compiled then + old_current_module^.current_inputfile^.tempreopen; +{$endif TEST_TEMPCLOSE} + end; end else begin @@ -528,7 +570,7 @@ unit pmodules; {$else} if hp^.ppufile^.name^<>'' then {$endif} - load_ppu(hp,compile_system); + load_ppu(old_current_module,hp,compile_system); { add the files for the linker } addlinkerfiles(hp); end; @@ -567,11 +609,24 @@ unit pmodules; { we must preserve the unit chain } hp^.next:=nextmodule; if assigned(hp^.ppufile) then - load_ppu(hp,compile_system) + load_ppu(old_current_module,hp,compile_system) else begin +{$ifdef UseBrowser} + { here we need to remove the names ! } + hp^.sourcefiles.done; + hp^.sourcefiles.init; +{$endif not UseBrowser} +{$ifdef TEST_TEMPCLOSE} + if assigned(old_current_module^.current_inputfile) then + old_current_module^.current_inputfile^.tempclose; +{$endif TEST_TEMPCLOSE} Message1(parser_d_compiling_second_time,hp^.mainsource^); compile(hp^.mainsource^,compile_system); +{$ifdef TEST_TEMPCLOSE} + if not old_current_module^.compiled then + old_current_module^.current_inputfile^.tempreopen; +{$endif TEST_TEMPCLOSE} end; current_module^.compiled:=true; end; @@ -841,7 +896,8 @@ unit pmodules; } { generates static symbol table } p:=new(punitsymtable,init(staticsymtable,current_module^.unitname^)); - refsymtable:=p; + { must be done only after _USES !! (PM) + refsymtable:=p;} {Generate a procsym.} aktprocsym:=new(Pprocsym,init(current_module^.unitname^+'_init')); @@ -864,6 +920,8 @@ unit pmodules; symtablestack:=unitst^.next; parse_implementation_uses(unitst); + { now we can change refsymtable } + refsymtable:=p; { but reinsert the global symtable as lasts } unitst^.next:=symtablestack; @@ -946,12 +1004,7 @@ unit pmodules; pu:=pused_unit(pu^.next); end; inc(datasize,symtablestack^.datasize); - - - - { finish asmlist by adding segment starts } - - + { finish asmlist by adding segment starts } insertsegment; end; @@ -1020,6 +1073,9 @@ unit pmodules; refsymtable:=st; + { necessary for browser } + loaded_units.insert(current_module); + {Insert the symbols of the system unit into the stack of symbol tables.} symtablestack:=systemunit; @@ -1081,24 +1137,27 @@ unit pmodules; datasize:=symtablestack^.datasize; - symtablestack^.check_forwards; + { symtablestack^.check_forwards; symtablestack^.allsymbolsused; - - - - { finish asmlist by adding segment starts } - - + done in compile_proc_body } + { finish asmlist by adding segment starts } insertsegment; - - - end; end. { $Log$ - Revision 1.13 1998-05-12 10:47:00 peter + Revision 1.14 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.13 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/pp.pas b/compiler/pp.pas index f39e3e2b96..17cbf46513 100644 --- a/compiler/pp.pas +++ b/compiler/pp.pas @@ -57,17 +57,17 @@ { and only one of the two } {$ifndef I386} {$ifndef M68K} - {$fatalerror One of the switches I386 or M68K must be defined} + {$fatal One of the switches I386 or M68K must be defined} {$endif M68K} {$endif I386} {$ifdef I386} {$ifdef M68K} - {$fatalerror ONLY one of the switches I386 or M68K must be defined} + {$fatal ONLY one of the switches I386 or M68K must be defined} {$endif M68K} {$endif I386} {$ifdef support_mmx} {$ifndef i386} - {$fatalerror I386 switch must be on for MMX support} + {$fatal I386 switch must be on for MMX support} {$endif i386} {$endif support_mmx} {$endif} @@ -195,6 +195,13 @@ var procedure myexit;{$ifndef FPC}far;{$endif} begin exitproc:=oldexit; +{$ifdef UseBrowser} + if browser_file_open then + begin + close(browserfile); + browser_file_open:=false; + end; +{$endif UseBrowser} {$ifdef tp} if use_big then symbolstream.done; @@ -353,7 +360,17 @@ begin end. { $Log$ - Revision 1.10 1998-05-12 10:47:00 peter + Revision 1.11 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.10 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index e381343962..7c1ca6d34f 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -569,6 +569,12 @@ unit pstatmnt; function _asm_statement : ptree; begin + if (aktprocsym^.definition^.options and poinline)<>0 then + Begin + Comment(V_Warning,'asm statement inside inline procedure/function not yet supported'); + Comment(V_Warning,'inlining disabled'); + aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline; + End; case aktasmmode of I386_ATT : _asm_statement:=ratti386.assemble; I386_INTEL : _asm_statement:=rai386.assemble; @@ -801,15 +807,11 @@ unit pstatmnt; var first,last : ptree; -{$ifdef UseTokenInfo} filepos : tfileposinfo; -{$endif UseTokenInfo} begin first:=nil; -{$ifdef UseTokenInfo} filepos:=tokenpos; -{$endif UseTokenInfo} consume(_BEGIN); inc(statement_level); @@ -845,11 +847,7 @@ unit pstatmnt; dec(statement_level); last:=gensinglenode(blockn,first); -{$ifdef UseTokenInfo} set_tree_filepos(last,filepos); -{$else UseTokenInfo} - set_file_line(first,last); -{$endif UseTokenInfo} statement_block:=last; end; @@ -859,17 +857,13 @@ unit pstatmnt; p : ptree; code : ptree; labelnr : plabel; -{$ifdef UseTokenInfo} filepos : tfileposinfo; -{$endif UseTokenInfo} label ready; begin -{$ifdef UseTokenInfo} filepos:=tokenpos; -{$endif UseTokenInfo} case token of _GOTO : begin if not(cs_support_goto in aktswitches)then @@ -929,7 +923,9 @@ unit pstatmnt; end; } _EXIT : code:=exit_statement; - _ASM : code:=_asm_statement; + _ASM : begin + code:=_asm_statement; + end; else begin if (token=INTCONST) or @@ -938,6 +934,11 @@ unit pstatmnt; (pattern='RESULT'))) then begin getsym(pattern,false); + lastsymknown:=true; + lastsrsym:=srsym; + { it is NOT necessarily the owner + it can be a withsymtable !!! } + lastsrsymtable:=srsymtable; if assigned(srsym) and (srsym^.typ=labelsym) then begin consume(token); @@ -948,7 +949,7 @@ unit pstatmnt; { statement modifies srsym } labelnr:=plabelsym(srsym)^.number; - + lastsymknown:=false; { the pointer to the following instruction } { isn't a very clean way } {$ifdef tp} @@ -965,13 +966,19 @@ unit pstatmnt; if not(p^.treetype in [calln,assignn,breakn,inlinen, continuen]) then Message(cg_e_illegal_expression); + { specify that we don't use the value returned by the call } + { Question : can this be also improtant + for inlinen ?? + it is used for : + - dispose of temp stack space + - dispose on FPU stack } + if p^.treetype=calln then + p^.return_value_used:=false; code:=p; end; end; ready: -{$ifdef UseTokenInfo} set_tree_filepos(code,filepos); -{$endif UseTokenInfo} statement:=code; end; @@ -1091,8 +1098,10 @@ unit pstatmnt; end; { set the framepointer to esp for assembler functions } { but only if the are no local variables } + { added no parameter also (PM) } if ((aktprocsym^.definition^.options and poassembler)<>0) and - (aktprocsym^.definition^.localst^.datasize=0) then + (aktprocsym^.definition^.localst^.datasize=0) and + (aktprocsym^.definition^.parast^.datasize=0) then begin {$ifdef i386} procinfo.framepointer:=R_ESP; @@ -1110,7 +1119,17 @@ unit pstatmnt; end. { $Log$ - Revision 1.10 1998-05-11 13:07:56 peter + Revision 1.11 1998-05-20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.10 1998/05/11 13:07:56 peter + $ifdef NEWPPU for the new ppuformat + $define GDB not longer required * removed all warnings and stripped some log comments diff --git a/compiler/ra68k.pas b/compiler/ra68k.pas index 1bf73dd84a..c65f6163b9 100644 --- a/compiler/ra68k.pas +++ b/compiler/ra68k.pas @@ -73,7 +73,7 @@ var Implementation uses - globals,AsmUtils,strings,hcodegen,scanner,aasm, + files,globals,AsmUtils,strings,hcodegen,scanner,aasm, cobjects,verbose,symtable; @@ -249,6 +249,9 @@ var end; { Possiblities for first token in a statement: } { Local Label, Label, Directive, Prefix or Opcode.... } + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; if firsttoken and not (c in [newline,#13,'{',';']) then begin @@ -2169,7 +2172,17 @@ Begin end. { $Log$ - Revision 1.2 1998-04-29 10:34:01 pierre + Revision 1.3 1998-05-20 09:42:36 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.2 1998/04/29 10:34:01 pierre + added some code for ansistring (not complete nor working yet) * corrected operator overloading * corrected nasm output diff --git a/compiler/radi386.pas b/compiler/radi386.pas index e285bef8ac..ef2eaf9e8e 100644 --- a/compiler/radi386.pas +++ b/compiler/radi386.pas @@ -32,7 +32,7 @@ unit radi386; implementation uses - i386,hcodegen,globals,scanner,aasm, + files,i386,hcodegen,globals,scanner,aasm, cobjects,symtable,types,verbose,asmutils; function assemble : ptree; @@ -73,10 +73,13 @@ unit radi386; retstr:=upper(tostr(procinfo.retoffset)+'('+att_reg2str[procinfo.framepointer]+')') else retstr:=''; - c:=asmgetchar; + c:=asmgetchar; code:=new(paasmoutput,init); while not(ende) do begin + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; case c of 'A'..'Z','a'..'z','_' : begin hs:=''; @@ -236,7 +239,17 @@ unit radi386; end. { $Log$ - Revision 1.2 1998-04-08 16:58:06 pierre + Revision 1.3 1998-05-20 09:42:36 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.2 1998/04/08 16:58:06 pierre * several bugfixes ADD ADC and AND are also sign extended nasm output OK (program still crashes at end diff --git a/compiler/rai386.pas b/compiler/rai386.pas index 547be4ea94..1425482a16 100644 --- a/compiler/rai386.pas +++ b/compiler/rai386.pas @@ -82,7 +82,7 @@ var Implementation Uses - aasm,globals,AsmUtils,strings,hcodegen,scanner, + files,aasm,globals,AsmUtils,strings,hcodegen,scanner, cobjects,verbose,types; @@ -350,6 +350,9 @@ var c := asmgetchar; { Possiblities for first token in a statement: } { Local Label, Label, Directive, Prefix or Opcode.... } + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; if firsttoken and not (c in [newline,#13,'{',';']) then begin firsttoken := FALSE; @@ -3366,7 +3369,17 @@ Begin end. { $Log$ - Revision 1.4 1998-04-29 10:34:03 pierre + Revision 1.5 1998-05-20 09:42:36 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.4 1998/04/29 10:34:03 pierre + added some code for ansistring (not complete nor working yet) * corrected operator overloading * corrected nasm output diff --git a/compiler/ratti386.pas b/compiler/ratti386.pas index 5cad94715f..e4df7a63e4 100644 --- a/compiler/ratti386.pas +++ b/compiler/ratti386.pas @@ -75,7 +75,7 @@ var Implementation Uses - aasm,globals,AsmUtils,strings,hcodegen,scanner, + files,aasm,globals,AsmUtils,strings,hcodegen,scanner, cobjects,verbose,symtable,types; type @@ -327,6 +327,9 @@ const c:=asmgetchar; { Possiblities for first token in a statement: } { Local Label, Label, Directive, Prefix or Opcode.... } + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; if firsttoken and not (c in [newline,#13,'{',';']) then begin firsttoken := FALSE; @@ -3678,7 +3681,17 @@ end. { $Log$ - Revision 1.5 1998-04-29 13:52:23 peter + Revision 1.6 1998-05-20 09:42:37 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.5 1998/04/29 13:52:23 peter * small optimize fix Revision 1.4 1998/04/29 10:34:04 pierre diff --git a/compiler/scanner.pas b/compiler/scanner.pas index 4b1f2d0355..c3e2beda52 100644 --- a/compiler/scanner.pas +++ b/compiler/scanner.pas @@ -160,15 +160,7 @@ unit scanner; preprocstack : ppreprocstack; -{$ifdef UseTokenInfo} -{ type - ttokeninfo = record - token : ttoken; - fi : tfileposinfo; - end; - ptokeninfo = ^ttokeninfo; } var tokenpos : tfileposinfo; -{$endif UseTokenInfo} {public} procedure syntaxerror(const s : string); @@ -659,24 +651,17 @@ unit scanner; function yylex : ttoken; var y : ttoken; -{$ifdef UseTokenInfo} - fileindex,line,column : longint; -{$endif UseTokenInfo} code : word; l : longint; mac : pmacrosym; hp : pinputfile; hp2 : pchar; -{$ifdef UseTokenInfo} label exit_label; -{$endif UseTokenInfo} begin -{$ifdef UseTokenInfo} - line:=current_module^.current_inputfile^.line_no; - column:=get_current_col; - fileindex:=current_module^.current_index; -{$endif UseTokenInfo} + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; { was the last character a point ? } { this code is needed because the scanner if there is a 1. found if } { this is a floating point number or range like 1..3 } @@ -686,39 +671,29 @@ unit scanner; if c='.' then begin readchar; -{$ifndef UseTokenInfo} - yylex:=POINTPOINT; - exit; - end; - yylex:=POINT; - exit; -{$else UseTokenInfo} yylex:=POINTPOINT; goto exit_label; end; yylex:=POINT; goto exit_label; -{$endif UseTokenInfo} end; repeat case c of '{' : skipcomment; - ' ',#9..#13 : skipspace; + ' ',#9..#13 : skipspace; else break; end; until false; lasttokenpos:=longint(inputpointer); -{$ifdef UseTokenInfo} - line:=current_module^.current_inputfile^.line_no; - column:=get_current_col; - fileindex:=current_module^.current_index; + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; { will become line:=lasttokenpos ??;} -{$endif UseTokenInfo} case c of - '_','A'..'Z', + '_','A'..'Z', 'a'..'z' : begin orgpattern:=readstring; pattern:=upper(orgpattern); @@ -740,6 +715,9 @@ unit scanner; hp^.next:=current_module^.current_inputfile; current_module^.current_inputfile:=hp; status.currentsource:=current_module^.current_inputfile^.name^; + { I don't think that we should do that + because otherwise the file will be searched !! (PM) + but there is the problem of index !! } current_module^.sourcefiles.register_file(hp); current_module^.current_index:=hp^.ref_index; { set an own buffer } @@ -772,29 +750,17 @@ unit scanner; end; yylex:=ID; end; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '$' : begin pattern:=readnumber; yylex:=INTCONST; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '%' : begin pattern:=readnumber; yylex:=INTCONST; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '0'..'9' : begin pattern:=readnumber; @@ -805,11 +771,7 @@ unit scanner; begin s_point:=true; yylex:=INTCONST; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; pattern:=pattern+'.'; while c in ['0'..'9'] do @@ -818,11 +780,7 @@ unit scanner; readchar; end; yylex:=REALNUMBER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; 'e','E' : begin pattern:=pattern+'E'; @@ -840,46 +798,26 @@ unit scanner; readchar; end; yylex:=REALNUMBER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; end; yylex:=INTCONST; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; ';' : begin readchar; yylex:=SEMICOLON; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '[' : begin readchar; yylex:=LECKKLAMMER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; ']' : begin readchar; yylex:=RECKKLAMMER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '(' : begin readchar; @@ -894,20 +832,12 @@ unit scanner; exit; end; yylex:=LKLAMMER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; ')' : begin readchar; yylex:=RKLAMMER; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '+' : begin readchar; @@ -915,18 +845,10 @@ unit scanner; begin readchar; yylex:=_PLUSASN; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; yylex:=PLUS; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '-' : begin readchar; @@ -934,18 +856,10 @@ unit scanner; begin readchar; yylex:=_MINUSASN; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; yylex:=MINUS; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; ':' : begin readchar; @@ -953,18 +867,10 @@ unit scanner; begin readchar; yylex:=ASSIGNMENT; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; yylex:=COLON; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '*' : begin readchar; @@ -979,11 +885,7 @@ unit scanner; end else yylex:=STAR; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '/' : begin readchar; @@ -993,11 +895,7 @@ unit scanner; begin readchar; yylex:=_SLASHASN; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; end; '/' : begin @@ -1011,20 +909,12 @@ unit scanner; end; end; yylex:=SLASH; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '=' : begin readchar; yylex:=EQUAL; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '.' : begin readchar; @@ -1032,19 +922,11 @@ unit scanner; begin readchar; yylex:=POINTPOINT; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end else yylex:=POINT; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '@' : begin readchar; @@ -1055,20 +937,12 @@ unit scanner; end else yylex:=KLAMMERAFFE; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; ',' : begin readchar; yylex:=COMMA; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '''','#','^' : begin if c='^' then @@ -1084,11 +958,7 @@ unit scanner; else begin yylex:=CARET; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; end else @@ -1135,11 +1005,7 @@ unit scanner; yylex:=CCHAR else yylex:=CSTRING; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '>' : begin readchar; @@ -1147,37 +1013,21 @@ unit scanner; '=' : begin readchar; yylex:=GTE; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '>' : begin readchar; yylex:=_SHR; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '<' : begin { >< is for a symetric diff for sets } readchar; yylex:=SYMDIF; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; end; yylex:=GT; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '<' : begin readchar; @@ -1185,57 +1035,32 @@ unit scanner; '>' : begin readchar; yylex:=UNEQUAL; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '=' : begin readchar; yylex:=LTE; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; '<' : begin readchar; yylex:=_SHL; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; end; yylex:=LT; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; #26 : begin yylex:=_EOF; -{$ifndef UseTokenInfo} - exit; -{$else UseTokenInfo} goto exit_label; -{$endif UseTokenInfo} end; else begin Message(scan_f_illegal_char); end; end; -{$ifdef UseTokenInfo} - exit_label: - tokenpos.fileindex:=fileindex; - tokenpos.line:=line; - tokenpos.column:=column; -{$endif UseTokenInfo} + exit_label: end; @@ -1248,6 +1073,9 @@ unit scanner; end else readchar; + tokenpos.line:=current_module^.current_inputfile^.line_no; + tokenpos.column:=get_current_col; + tokenpos.fileindex:=current_module^.current_index; case c of '{' : begin skipcomment; @@ -1326,7 +1154,8 @@ unit scanner; current_module^.current_index:=fileinfo.fileindex; current_module^.current_inputfile:= pinputfile(current_module^.sourcefiles.get_file(fileinfo.fileindex)); - current_module^.current_inputfile^.line_no:=fileinfo.line; + if assigned(current_module^.current_inputfile) then + current_module^.current_inputfile^.line_no:=fileinfo.line; {fileinfo.fileindex:=current_module^.current_inputfile^.ref_index;} { should allways be the same !! } { fileinfo.column:=get_current_col; } @@ -1389,7 +1218,17 @@ unit scanner; end. { $Log$ - Revision 1.18 1998-05-12 10:47:00 peter + Revision 1.19 1998-05-20 09:42:37 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.18 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default diff --git a/compiler/tgeni386.pas b/compiler/tgeni386.pas index 5f9456d093..67ab0797a0 100644 --- a/compiler/tgeni386.pas +++ b/compiler/tgeni386.pas @@ -58,7 +58,12 @@ unit tgeni386; procedure setfirsttemp(l : longint); function gettempsize : longint; function gettempofsize(size : longint) : longint; + { special call for inlined procedures } + function gettempofsizepersistant(size : longint) : longint; + { for parameter func returns } + procedure persistanttemptonormal(pos : longint); procedure ungettemp(pos : longint;size : longint); + procedure ungetpersistanttemp(pos : longint;size : longint); procedure gettempofsizereference(l : longint;var ref : treference); function istemp(const ref : treference) : boolean; procedure ungetiftemp(const ref : treference); @@ -321,6 +326,7 @@ unit tgeni386; next : pfreerecord; pos : longint; size : longint; + persistant : boolean; { used for inlined procedures } {$ifdef EXTDEBUG} line : longint; {$endif} @@ -348,7 +354,7 @@ unit tgeni386; begin {$ifdef EXTDEBUG} Comment(V_Warning,'temporary assignment of size ' - +tostr(templist^.size)+' from '+tostr(templist^.line)+ + +tostr(templist^.size)+' from line '+tostr(templist^.line)+ +' at pos '+tostr(templist^.pos)+ ' not freed at the end of the procedure'); {$endif} @@ -378,12 +384,14 @@ unit tgeni386; function gettempofsize(size : longint) : longint; var - last,hp : pfreerecord; + tl,last,hp : pfreerecord; + ofs : longint; begin { this code comes from the heap management of FPC ... } if (size mod 4)<>0 then size:=size+(4-(size mod 4)); + ofs:=0; if assigned(tmpfreelist) then begin last:=nil; @@ -393,7 +401,7 @@ unit tgeni386; { first fit } if hp^.size>=size then begin - gettempofsize:=hp^.pos; + ofs:=hp^.pos; if hp^.pos-size < maxtemp then maxtemp := hp^.size-size; { the whole block is needed ? } @@ -410,17 +418,45 @@ unit tgeni386; tmpfreelist:=nil; dispose(hp); end; - exit; + break; end; last:=hp; hp:=hp^.next; end; end; { nothing free is big enough : expand temp } - gettempofsize:=lastoccupied-size; - lastoccupied:=lastoccupied-size; - if lastoccupied < maxtemp then - maxtemp := lastoccupied; + if ofs=0 then + begin + ofs:=lastoccupied-size; + lastoccupied:=lastoccupied-size; + if lastoccupied < maxtemp then + maxtemp := lastoccupied; + end; + new(tl); + tl^.pos:=ofs; + tl^.size:=size; + tl^.next:=templist; + tl^.persistant:=false; + templist:=tl; +{$ifdef EXTDEBUG} + tl^.line:=current_module^.current_inputfile^.line_no; +{$endif} + gettempofsize:=ofs; + end; + + function gettempofsizepersistant(size : longint) : longint; + + var + l : longint; + + begin + l:=gettempofsize(size); + templist^.persistant:=true; +{$ifdef EXTDEBUG} + Comment(V_Debug,'temp managment : call to gettempofsizepersistant()'+ + ' with size '+tostr(size)+' returned '+tostr(l)); +{$endif} + gettempofsizepersistant:=l; end; function gettempsize : longint; @@ -434,29 +470,77 @@ unit tgeni386; procedure gettempofsizereference(l : longint;var ref : treference); - var - tl : pfreerecord; - begin { do a reset, because the reference isn't used } reset_reference(ref); ref.offset:=gettempofsize(l); ref.base:=procinfo.framepointer; - new(tl); - tl^.pos:=ref.offset; - tl^.size:=l; - tl^.next:=templist; - templist:=tl; -{$ifdef EXTDEBUG} - tl^.line:=current_module^.current_inputfile^.line_no; -{$endif} end; function istemp(const ref : treference) : boolean; begin + { ref.index = R_NO was missing + led to problems with local arrays + with lower bound > 0 (PM) } istemp:=((ref.base=procinfo.framepointer) and - (ref.offset=tl^.pos) and + (ref.offsetp2^.error then + if oldp^.resulttype<>p^.resulttype then + begin + error_found:=true; + if is_equal(oldp^.resulttype,p^.resulttype) then + comment(v_debug,'resulttype fields are different but equal') + else + comment(v_warning,'resulttype fields are really different'); + end; + if oldp^.treetype<>p^.treetype then + begin + comment(v_warning,'treetype field different'); + error_found:=true; + end + else + comment(v_debug,' treetype '+tostr(longint(oldp^.treetype))); + if oldp^.error<>p^.error then begin comment(v_warning,'error field different'); error_found:=true; end; - if p1^.disposetyp<>p2^.disposetyp then + if oldp^.disposetyp<>p^.disposetyp then begin comment(v_warning,'disposetyp field different'); error_found:=true; end; { is true, if the right and left operand are swaped } - if p1^.swaped<>p2^.swaped then + if oldp^.swaped<>p^.swaped then begin comment(v_warning,'swaped field different'); error_found:=true; end; { the location of the result of this node } - if p1^.location.loc<>p2^.location.loc then + if oldp^.location.loc<>p^.location.loc then begin comment(v_warning,'location.loc field different'); error_found:=true; end; { the number of registers needed to evalute the node } - if p1^.registers32<>p2^.registers32 then + if oldp^.registers32<>p^.registers32 then begin comment(v_warning,'registers32 field different'); - comment(v_warning,tostr(p1^.registers32)+'<>'+tostr(p2^.registers32)); + comment(v_warning,' old '+tostr(oldp^.registers32)+'<> new '+tostr(p^.registers32)); error_found:=true; end; - if p1^.registersfpu<>p2^.registersfpu then + if oldp^.registersfpu<>p^.registersfpu then begin comment(v_warning,'registersfpu field different'); error_found:=true; end; {$ifdef SUPPORT_MMX} - if p1^.registersmmx<>p2^.registersmmx then + if oldp^.registersmmx<>p^.registersmmx then begin comment(v_warning,'registersmmx field different'); error_found:=true; end; {$endif SUPPORT_MMX} - if p1^.left<>p2^.left then + if oldp^.left<>p^.left then begin comment(v_warning,'left field different'); error_found:=true; end; - if p1^.right<>p2^.right then + if oldp^.right<>p^.right then begin comment(v_warning,'right field different'); error_found:=true; end; - if p1^.resulttype<>p2^.resulttype then - begin - error_found:=true; - if is_equal(p1^.resulttype,p2^.resulttype) then - comment(v_debug,'resulttype fields are different but equal') - else - comment(v_warning,'resulttype fields are really different'); - end; - if p1^.fileinfo.line<>p2^.fileinfo.line then + if oldp^.fileinfo.line<>p^.fileinfo.line then begin comment(v_warning,'fileinfo.line field different'); error_found:=true; end; - if p1^.fileinfo.column<>p2^.fileinfo.column then + if oldp^.fileinfo.column<>p^.fileinfo.column then begin comment(v_warning,'fileinfo.column field different'); error_found:=true; end; - if p1^.fileinfo.fileindex<>p2^.fileinfo.fileindex then + if oldp^.fileinfo.fileindex<>p^.fileinfo.fileindex then begin comment(v_warning,'fileinfo.fileindex field different'); error_found:=true; end; - if p1^.pragmas<>p2^.pragmas then + if oldp^.pragmas<>p^.pragmas then begin comment(v_warning,'pragmas field different'); error_found:=true; end; {$ifdef extdebug} - if p1^.firstpasscount<>p2^.firstpasscount then + if oldp^.firstpasscount<>p^.firstpasscount then begin comment(v_warning,'firstpasscount field different'); error_found:=true; end; {$endif extdebug} - if p1^.treetype=p2^.treetype then - case p1^.treetype of + if oldp^.treetype=p^.treetype then + case oldp^.treetype of addn : begin - if p1^.use_strconcat<>p2^.use_strconcat then + if oldp^.use_strconcat<>p^.use_strconcat then begin comment(v_warning,'use_strconcat field different'); error_found:=true; end; - if p1^.string_typ<>p2^.string_typ then + if oldp^.string_typ<>p^.string_typ then begin comment(v_warning,'stringtyp field different'); error_found:=true; @@ -1287,12 +1295,12 @@ unit tree; callparan : {(is_colon_para : boolean;exact_match_found : boolean);} begin - if p1^.is_colon_para<>p2^.is_colon_para then + if oldp^.is_colon_para<>p^.is_colon_para then begin comment(v_warning,'use_strconcat field different'); error_found:=true; end; - if p1^.exact_match_found<>p2^.exact_match_found then + if oldp^.exact_match_found<>p^.exact_match_found then begin comment(v_warning,'exact_match_found field different'); error_found:=true; @@ -1301,12 +1309,12 @@ unit tree; assignn : {(assigntyp : tassigntyp;concat_string : boolean);} begin - if p1^.assigntyp<>p2^.assigntyp then + if oldp^.assigntyp<>p^.assigntyp then begin comment(v_warning,'assigntyp field different'); error_found:=true; end; - if p1^.concat_string<>p2^.concat_string then + if oldp^.concat_string<>p^.concat_string then begin comment(v_warning,'concat_string field different'); error_found:=true; @@ -1316,22 +1324,22 @@ unit tree; {(symtableentry : psym;symtable : psymtable; is_absolute,is_first : boolean);} begin - if p1^.symtableentry<>p2^.symtableentry then + if oldp^.symtableentry<>p^.symtableentry then begin comment(v_warning,'symtableentry field different'); error_found:=true; end; - if p1^.symtable<>p2^.symtable then + if oldp^.symtable<>p^.symtable then begin comment(v_warning,'symtable field different'); error_found:=true; end; - if p1^.is_absolute<>p2^.is_absolute then + if oldp^.is_absolute<>p^.is_absolute then begin comment(v_warning,'is_absolute field different'); error_found:=true; end; - if p1^.is_first<>p2^.is_first then + if oldp^.is_first<>p^.is_first then begin comment(v_warning,'is_first field different'); error_found:=true; @@ -1343,32 +1351,32 @@ unit tree; methodpointer : ptree; no_check,unit_specific : boolean);} begin - if p1^.symtableprocentry<>p2^.symtableprocentry then + if oldp^.symtableprocentry<>p^.symtableprocentry then begin comment(v_warning,'symtableprocentry field different'); error_found:=true; end; - if p1^.symtableproc<>p2^.symtableproc then + if oldp^.symtableproc<>p^.symtableproc then begin comment(v_warning,'symtableproc field different'); error_found:=true; end; - if p1^.procdefinition<>p2^.procdefinition then + if oldp^.procdefinition<>p^.procdefinition then begin comment(v_warning,'procdefinition field different'); error_found:=true; end; - if p1^.methodpointer<>p2^.methodpointer then + if oldp^.methodpointer<>p^.methodpointer then begin comment(v_warning,'methodpointer field different'); error_found:=true; end; - if p1^.no_check<>p2^.no_check then + if oldp^.no_check<>p^.no_check then begin comment(v_warning,'no_check field different'); error_found:=true; end; - if p1^.unit_specific<>p2^.unit_specific then + if oldp^.unit_specific<>p^.unit_specific then begin error_found:=true; comment(v_warning,'unit_specific field different'); @@ -1376,7 +1384,7 @@ unit tree; end; ordconstn : begin - if p1^.value<>p2^.value then + if oldp^.value<>p^.value then begin comment(v_warning,'value field different'); error_found:=true; @@ -1384,17 +1392,17 @@ unit tree; end; realconstn : begin - if p1^.valued<>p2^.valued then + if oldp^.valued<>p^.valued then begin comment(v_warning,'valued field different'); error_found:=true; end; - if p1^.labnumber<>p2^.labnumber then + if oldp^.labnumber<>p^.labnumber then begin comment(v_warning,'labnumber field different'); error_found:=true; end; - if p1^.realtyp<>p2^.realtyp then + if oldp^.realtyp<>p^.realtyp then begin comment(v_warning,'realtyp field different'); error_found:=true; @@ -1527,7 +1535,17 @@ unit tree; end. { $Log$ - Revision 1.9 1998-05-12 10:47:00 peter + Revision 1.10 1998-05-20 09:42:38 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.9 1998/05/12 10:47:00 peter * moved printstatus to verb_def + V_Normal which is between V_Error and V_Warning and doesn't have a prefix like error: warning: and is included in V_Default