* better position info with UseTokenInfo

UseTokenInfo greatly simplified
  + added check for changed tree after first time firstpass
    (if we could remove all the cases were it happen
    we could skip all firstpass if firstpasscount > 1)
    Only with ExtDebug

compiler/ag386int.pas

@@ -594,9 +594,13 @@ ait_stab_function_name : ;
          AsmLn;
          AsmWriteLn('SECTION .data');
 {$ifdef EXTDEBUG}
-         AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
+         if not comp_unit then
-         AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
 {$endif EXTDEBUG}
+           begin
+              DataSegment^.insert(new(pai_align,init(4)));
+              DataSegment^.insert(new(pai_string,init('target: '+target_info.short_name)));
+              DataSegment^.insert(new(pai_string,init('compiled by FPC '+version_string)));
+           end;
          WriteTree(datasegment);
          WriteTree(consts);
          WriteTree(rttilist);
@@ -624,9 +628,13 @@ ait_stab_function_name : ;
          AsmLn;
          AsmWriteLn('_DATA'#9#9'SEGMENT'#9'PARA PUBLIC USE32 ''DATA''');
 {$ifdef EXTDEBUG}
-         AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
+         if not comp_unit then
-         AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
 {$endif EXTDEBUG}
+           begin
+              DataSegment^.insert(new(pai_align,init(4)));
+              DataSegment^.insert(new(pai_string,init('target: '+target_info.short_name)));
+              DataSegment^.insert(new(pai_string,init('compiled by FPC '+version_string)));
+           end;
          WriteTree(datasegment);
          WriteTree(consts);
          WriteTree(rttilist);
@@ -649,7 +657,15 @@ ait_stab_function_name : ;
 end.
 {
   $Log$
-  Revision 1.6  1998-05-04 17:54:24  peter
+  Revision 1.7  1998-05-06 08:38:32  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.6  1998/05/04 17:54:24  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

compiler/aopt386.inc

@@ -829,8 +829,12 @@ Begin
         Inc(NrOfInstrSinceLastMod[TmpReg]);
       Case p^.typ Of
         ait_label: DestroyAllRegs(p);
-        ait_labeled_instruction, ait_stabs, ait_stabn,
+        ait_labeled_instruction
-        ait_stab_function_name:; {nothing changes}
+{$ifdef GDB}
+        , ait_stabs, ait_stabn,
+        ait_stab_function_name
+{$endif GDB}
+        :; {nothing changes}
 {$ifdef regalloc}
         ait_regalloc, ait_regdealloc:;
 {$endif regalloc}
@@ -1035,7 +1039,13 @@ Begin
                                      hp2 := p;
                                      For Cnt2 := 1 to Cnt Do
                                        Begin
-                                         If Not(Pai(p)^.typ In [ait_stabs, ait_stabn, ait_stab_function_name]) Then
+                                         { Note to Jonas :
+                                           ait_stab_function_name is only at the begin of one function
+                                           ait_stabn is only inserted in ag so you should not see any
+                                           ait_stabs are only in head and tail of procs
+                                           so you should no have problems with those neither !! (PM)
+                                           Tell me if I am wrong
+                                         If Not(Pai(p)^.typ In [ait_stabs, ait_stabn, ait_stab_function_name]) Then }
                                            Begin
                                              If (hp1 = nil) And
                                                 Not(RegInInstruction(Tregister(Pai386(hp2)^.op2), p))
@@ -1191,7 +1201,15 @@ End;
 
 {
  $Log$
- Revision 1.5  1998-04-29 10:33:42  pierre
+ Revision 1.6  1998-05-06 08:38:33  pierre
+   * better position info with UseTokenInfo
+     UseTokenInfo greatly simplified
+   + added check for changed tree after first time firstpass
+     (if we could remove all the cases were it happen
+     we could skip all firstpass if firstpasscount > 1)
+     Only with ExtDebug
+
+ Revision 1.5  1998/04/29 10:33:42  pierre
    + added some code for ansistring (not complete nor working yet)
    * corrected operator overloading
    * corrected nasm output

compiler/aopt386.pas

@@ -42,7 +42,10 @@ Unit aopt386;
 
         {ait_* types which don't result in executable code or which don't
          influence the way the program runs/behaves}
-  Const SkipInstr = [ait_comment,ait_stabs, ait_stabn, ait_stab_function_name
+  Const SkipInstr = [ait_comment
+{$ifdef GDB}
+  ,ait_stabs, ait_stabn, ait_stab_function_name
+{$endif GDB}
 {$ifdef regalloc}
                      ,ait_regalloc, ait_regdealloc
 {$endif regalloc}
@@ -1615,7 +1618,15 @@ end;
 End.
 {
   $Log$
-  Revision 1.8  1998-04-29 10:33:43  pierre
+  Revision 1.9  1998-05-06 08:38:34  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.8  1998/04/29 10:33:43  pierre
     + added some code for ansistring (not complete nor working yet)
     * corrected operator overloading
     * corrected nasm output

compiler/cgi386.pas

@@ -224,8 +224,8 @@ implementation
                          { first handle local and temporary variables }
                          if (symtabletype=parasymtable) or
 {$ifdef TestInline}
-                            (symtabletype=inlinelocalsymtable) then
+                            (symtabletype=inlinelocalsymtable) or
-                            (symtabletype=inlineparasymtable) then
+                            (symtabletype=inlineparasymtable) or
 {$endif TestInline}
                             (symtabletype=localsymtable) then
                            begin
@@ -3195,8 +3195,8 @@ implementation
                   ((p^.symtableproc^.symtabletype=objectsymtable) and
                   (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable)))
               else { inlined proc }
-                { inlined code is in p^.right }
+                { inlined code is in inlinecode }
-                secondpass(p^.right);
+                secondpass(inlinecode);
               if ((p^.procdefinition^.options and poclearstack)<>0) then
                 begin
                    { consider the alignment with the rest (PM) }
@@ -5266,6 +5266,8 @@ do_jmp:
 
          { true, if we can omit the range check of the jump table }
          jumptable_no_range : boolean;
+         { where to put the jump table }
+         jumpsegment : paasmoutput;
 
       procedure gentreejmp(p : pcaserecord);
 
@@ -5420,10 +5422,10 @@ do_jmp:
                genitem(t^.less);
              { fill possible hole }
              for i:=last+1 to t^._low-1 do
-               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+               jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
                  (elselabel)))));
              for i:=t^._low to t^._high do
-               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+               jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
                     (t^.statement)))));
               last:=t^._high;
              if assigned(t^.greater) then
@@ -5462,9 +5464,9 @@ do_jmp:
            exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr)));
            { !!!!! generate tables
              if not(cs_littlesize in aktswitches^ ) then
-             datasegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
+             jumpsegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
            }
-           datasegment^.concat(new(pai_label,init(table)));
+           jumpsegment^.concat(new(pai_label,init(table)));
              last:=min_;
            genitem(hp);
              { !!!!!!!
@@ -5480,6 +5482,10 @@ do_jmp:
       begin
          getlabel(endlabel);
          getlabel(elselabel);
+         if smartlink then
+           jumpsegment:=procinfo.aktlocaldata
+         else
+           jumpsegment:=datasegment;
          with_sign:=is_signed(p^.left^.resulttype);
          if with_sign then
            begin
@@ -6017,6 +6023,10 @@ do_jmp:
                 end;
               do_secondpass(p);
 
+{$ifdef StoreFPULevel}
+              if assigned(aktprocsym) then
+                aktprocsym^.fpu_used:=p^.registersfpu;
+{$endif StoreFPULevel}
               { all registers can be used again }
               usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
 {$ifdef SUPPORT_MMX}
@@ -6033,7 +6043,15 @@ do_jmp:
 end.
 {
   $Log$
-  Revision 1.20  1998-05-01 16:38:44  florian
+  Revision 1.21  1998-05-06 08:38:36  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.20  1998/05/01 16:38:44  florian
     * handling of private and protected fixed
     + change_keywords_to_tp implemented to remove
       keywords which aren't supported by tp

compiler/cobjects.pas

@@ -143,7 +143,7 @@ unit cobjects;
           { gets a string }
           function get : string;
 {$ifdef UseTokenInfo}
-    function get_with_tokeninfo(var file_info : tfileposinfo) : string;
+          function get_with_tokeninfo(var file_info : tfileposinfo) : string;
 {$endif UseTokenInfo}
 
           { deletes all strings }
@@ -1063,7 +1063,15 @@ end;
 end.
 {
   $Log$
-  Revision 1.5  1998-04-30 15:59:40  pierre
+  Revision 1.6  1998-05-06 08:38:37  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.5  1998/04/30 15:59:40  pierre
     * GDB works again better :
       correct type info in one pass
     + UseTokenInfo for better source position

compiler/hcodegen.pas

@@ -88,7 +88,9 @@ unit hcodegen;
           exported : boolean;
 
           { code for the current procedure }
-          aktproccode,aktentrycode,aktexitcode : paasmoutput;
+          aktproccode,aktentrycode,
+          aktexitcode,aktlocaldata : paasmoutput;
+          { local data is used for smartlink }
        end;
 
     var
@@ -355,7 +357,15 @@ end.
 
 {
   $Log$
-  Revision 1.2  1998-04-29 10:33:53  pierre
+  Revision 1.3  1998-05-06 08:38:40  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.2  1998/04/29 10:33:53  pierre
     + added some code for ansistring (not complete nor working yet)
     * corrected operator overloading
     * corrected nasm output

compiler/parser.pas

@@ -120,12 +120,12 @@ unit parser;
     procedure compile(const filename:string;compile_system:boolean);
       var
          hp : pmodule;
-         comp_unit : boolean;
+         old_comp_unit : boolean;
 
          { some variables to save the compiler state }
          oldtoken : ttoken;
 {$ifdef UseTokenInfo}
-         oldtokeninfo : ptokeninfo;
+         oldtokenpos : tfileposinfo;
 {$endif UseTokenInfo}
          oldpattern : stringid;
 
@@ -222,6 +222,7 @@ unit parser;
          oldrefsymtable:=refsymtable;
          refsymtable:=nil;
          oldprocprefix:=procprefix;
+         old_comp_unit:=comp_unit;
 
          { a long time, this was only in init_parser
            but it should be reset to zero for each module }
@@ -239,7 +240,7 @@ unit parser;
          oldpattern:=pattern;
          oldtoken:=token;
 {$ifdef UseTokenInfo}
-         oldtokeninfo:=tokeninfo;
+         oldtokenpos:=tokenpos;
 {$endif UseTokenInfo}
          oldorgpattern:=orgpattern;
          old_block_type:=block_type;
@@ -289,12 +290,7 @@ unit parser;
          define_macros;
 
          { startup scanner }
-{$ifndef UseTokenInfo}
          token:=yylex;
-{$else UseTokenInfo}
-         tokeninfo:=yylex;
-         token:=tokeninfo^.token;
-{$endif UseTokenInfo}
 
          reset_gdb_info;
          { init asm writing }
@@ -482,10 +478,11 @@ done:
          pattern:=oldpattern;
          token:=oldtoken;
 {$ifdef UseTokenInfo}
-         tokeninfo:=oldtokeninfo;
+         tokenpos:=oldtokenpos;
 {$endif UseTokenInfo}
          orgpattern:=oldorgpattern;
          block_type:=old_block_type;
+         comp_unit:=old_comp_unit;
 
          { call donescanner before restoring preprocstack, because }
          { donescanner tests for a empty preprocstack              }
@@ -537,7 +534,15 @@ done:
 end.
 {
   $Log$
-  Revision 1.12  1998-05-04 17:54:28  peter
+  Revision 1.13  1998-05-06 08:38:42  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.12  1998/05/04 17:54:28  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

compiler/pass_1.pas

@@ -614,7 +614,7 @@ unit pass_1;
            exit;
 
          { overloaded operator ? }
-         if (p^.treetype=caretn) or
+         if (p^.treetype=starstarn) or
             (ld^.deftype=recorddef) or
             { <> and = are defined for classes }
             ((ld^.deftype=objectdef) and
@@ -731,6 +731,7 @@ unit pass_1;
                    Message(sym_e_type_mismatch);
                 end;
               disposetree(p);
+              firstpass(t);
               p:=t;
               exit;
               end
@@ -879,6 +880,7 @@ unit pass_1;
               dispose(s2);
 {$endif UseAnsiString}
               disposetree(p);
+              firstpass(t);
               p:=t;
               exit;
            end;
@@ -1287,6 +1289,11 @@ unit pass_1;
            exit;
 
          { determines result type for comparions }
+         { here the is a problem with multiple passes }
+         { example length(s)+1 gets internal 'longint' type first }
+         { if it is a arg it is converted to 'LONGINT' }
+         { but a second first pass will reset this to 'longint' }
+         if not assigned(p^.resulttype) then
          case p^.treetype of
             ltn,lten,gtn,gten,equaln,unequaln:
               begin
@@ -1336,6 +1343,7 @@ unit pass_1;
                  divn : t:=genordinalconstnode(p^.left^.value div p^.right^.value,s32bitdef);
               end;
               disposetree(p);
+              firstpass(t);
               p:=t;
               exit;
            end;
@@ -1378,6 +1386,7 @@ unit pass_1;
                  shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef);
               end;
               disposetree(p);
+              firstpass(t);
               p:=t;
               exit;
            end;
@@ -1660,6 +1669,7 @@ unit pass_1;
            begin
               t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
               disposetree(p);
+              firstpass(t);
               p:=t;
               exit;
            end;
@@ -1929,23 +1939,24 @@ unit pass_1;
            exit;
 
          { determine return type }
-         if p^.left^.resulttype^.deftype=arraydef then
+         if not assigned(p^.resulttype) then
-           p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
+           if p^.left^.resulttype^.deftype=arraydef then
-         else if (p^.left^.resulttype^.deftype=pointerdef) then
+             p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
-           begin
+           else if (p^.left^.resulttype^.deftype=pointerdef) then
-              { convert pointer to array }
+             begin
-              harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
+                { convert pointer to array }
-              parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
+                harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
-              p^.left:=gentypeconvnode(p^.left,harr);
+                parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
-              firstpass(p^.left);
+                p^.left:=gentypeconvnode(p^.left,harr);
-
+                firstpass(p^.left);
-              if codegenerror then
+  
-                exit;
+                if codegenerror then
-              p^.resulttype:=parraydef(harr)^.definition
+                  exit;
-           end
+                p^.resulttype:=parraydef(harr)^.definition
-         else
+             end
-         { indexed access to arrays }
+           else
-           p^.resulttype:=cchardef;
+           { indexed access to arrays }
+             p^.resulttype:=cchardef;
 
          { the register calculation is easy if a const index is used }
          if p^.right^.treetype=ordconstn then
@@ -2048,6 +2059,9 @@ unit pass_1;
               { convert constants direct }
               { not because of type conversion }
               t:=genrealconstnode(p^.left^.value);
+              { do a first pass here
+                because firstpass of typeconv does
+                not redo it for left field !! }
               firstpass(t);
               { the type can be something else than s64real !!}
               t:=gentypeconvnode(t,p^.resulttype);
@@ -2175,12 +2189,11 @@ unit pass_1;
           { Florian I think this is overestimated
             but I still do not really understand how to get this right (PM) }
           { Hmmm, I think we need only one reg to return the result of      }
-          { this node => so
+          { this node => so }
           if p^.registers32<1 then
             p^.registers32:=1;
-            should work (FK)
+          {  should work (FK)
-          }
+          p^.registers32:=p^.left^.registers32+1;}
-          p^.registers32:=p^.left^.registers32+1;
        end;
 
     procedure first_proc_to_procvar(var p : ptree);
@@ -2425,6 +2438,7 @@ unit pass_1;
                             begin
                                hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
                                disposetree(p);
+                               firstpass(hp);
                                p:=hp;
                                exit;
                             end
@@ -2444,6 +2458,7 @@ unit pass_1;
                               begin
                                  hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
                                  disposetree(p);
+                                 firstpass(hp);
                                  p:=hp;
                                  exit;
                               end
@@ -2461,6 +2476,7 @@ unit pass_1;
                             if p^.left^.treetype=ordconstn then
                               begin
                                  hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                                 firstpass(hp);
                                  disposetree(p);
                                  p:=hp;
                                  exit;
@@ -2504,6 +2520,7 @@ unit pass_1;
                    testrange(p^.resulttype,p^.left^.value);
                  hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
                  disposetree(p);
+                 firstpass(hp);
                  p:=hp;
                  exit;
               end;
@@ -2534,7 +2551,10 @@ unit pass_1;
            end;
          if defcoll=nil then
            begin
-              if not(assigned(p^.resulttype)) then
+              { this breaks typeconversions in write !!! (PM) }
+              {if not(assigned(p^.resulttype)) then }
+              if not(assigned(p^.resulttype)) or
+                (p^.left^.treetype=typeconvn) then
                 firstpass(p^.left)
               else
                 exit;
@@ -2691,6 +2711,9 @@ unit pass_1;
          must_be_valid:=false;
 
          { 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 }
@@ -3131,14 +3154,17 @@ unit pass_1;
                 begin
                    if assigned(p^.methodpointer) then
                      comment(v_fatal,'Unable to inline object methods');
-                   if assigned(p^.right) then
+                   if assigned(p^.right) and (p^.right^.treetype<>procinlinen) then
                      comment(v_fatal,'Unable to inline procvar calls');
                    { p^.treetype:=procinlinen; }
-                   if assigned(p^.procdefinition^.code) then
+                   if not assigned(p^.right) then
-                     p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
+                     begin
-                   else
+                        if assigned(p^.procdefinition^.code) then
-                     comment(v_fatal,'no code for inline procedure stored');
+                          p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
-                   firstpass(p^.right);
+                        else
+                          comment(v_fatal,'no code for inline procedure stored');
+                        firstpass(p^.right);
+                     end;
                 end
               else
                 procinfo.flags:=procinfo.flags or pi_do_call;
@@ -3204,6 +3230,10 @@ unit pass_1;
                 end;
            end;
 
+{$ifdef StoreFPULevel}
+         { a fpu can be used in any procedure !! }
+         p^.registersfpu:=p^.procdefinition^.fpu_used;
+{$endif StoreFPULevel}
          { if this is a call to a method calc the registers }
          if (p^.methodpointer<>nil) then
            begin
@@ -3307,6 +3337,7 @@ unit pass_1;
                   else
                     v:=porddef(Adef)^.bis;
                   hp:=genordinalconstnode(v,adef);
+                  firstpass(hp);
                   disposetree(p);
                   p:=hp;
                end;
@@ -4777,6 +4808,11 @@ unit pass_1;
          { there some calls of do_firstpass in the parser }
          oldis : pinputfile;
          oldnr : longint;
+{$ifdef extdebug}
+         str1,str2 : string;
+         oldp : ptree;
+         not_first : boolean;
+{$endif extdebug}
 
       begin
          { if we save there the whole stuff, }
@@ -4786,7 +4822,16 @@ unit pass_1;
          oldcodegenerror:=codegenerror;
          oldswitches:=aktswitches;
 {$ifdef extdebug}
-        inc(p^.firstpasscount);
+         if p^.firstpasscount>0 then
+           begin
+              move(p^,str1[1],sizeof(ttree));
+              str1[0]:=char(sizeof(ttree));
+              new(oldp);
+              oldp^:=p^;
+              not_first:=true;
+           end
+         else
+           not_first:=false;
 {$endif extdebug}
 
          codegenerror:=false;
@@ -4802,6 +4847,23 @@ unit pass_1;
               codegenerror:=codegenerror or oldcodegenerror;
            end
          else codegenerror:=true;
+{$ifdef extdebug}
+         if not_first then
+           begin
+              { dirty trick to compare two ttree's (PM) }
+              move(p^,str2[1],sizeof(ttree));
+              str2[0]:=char(sizeof(ttree));
+              if str1<>str2 then
+                begin
+                   comment(v_debug,'tree changed after first counting pass '
+                     +tostr(longint(p^.treetype)));
+                   compare_trees(p,oldp);
+                end;
+              dispose(oldp);
+           end;
+         if count_ref then
+           inc(p^.firstpasscount);
+{$endif extdebug}
          aktswitches:=oldswitches;
          current_module^.current_inputfile:=oldis;
          current_module^.current_inputfile^.line_no:=oldnr;
@@ -4829,7 +4891,15 @@ unit pass_1;
 end.
 {
   $Log$
-  Revision 1.16  1998-05-01 16:38:45  florian
+  Revision 1.17  1998-05-06 08:38:43  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.16  1998/05/01 16:38:45  florian
     * handling of private and protected fixed
     + change_keywords_to_tp implemented to remove
       keywords which aren't supported by tp

compiler/pbase.pas

@@ -45,9 +45,6 @@ unit pbase;
     var
        { contains the current token to be processes }
        token : ttoken;
-{$ifdef UseTokenInfo}
-       tokeninfo : ptokeninfo;
-{$endif UseTokenInfo}
 
        { size of data segment, set by proc_unit or proc_program }
        datasize : longint;
@@ -89,6 +86,10 @@ unit pbase;
     { sc is disposed                                         }
     procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
 
+    { just for an accurate position of the end of a procedure (PM) }
+    var
+       last_endtoken_filepos: tfileposinfo;
+
   implementation
 
 
@@ -124,7 +125,6 @@ unit pbase;
          j : integer;
 
       begin
-{$ifndef UseTokenInfo}
          if token<>i then
            begin
               if i<_AND then
@@ -143,33 +143,15 @@ unit pbase;
                 end;
            end
          else
-           token:=yylex;
+           begin
+             if token=_END then
+{$ifdef UseTokenInfo}
+                last_endtoken_filepos:=tokenpos;
 {$else UseTokenInfo}
-         if token<>i then
+                get_cur_file_pos(last_endtoken_filepos);
-           begin
-              if i<_AND then
-                syntaxerror(tokens[i])
-              else
-                begin
-
-                   { um die ProgrammgrӇe klein zu halten, }
-                   { wird f<>r ein Schl<68>sselwort-Token der  }
-                   { "Text" in der Schl<68>sselworttabelle    }
-                   { des Scanners nachgeschaut             }
-
-                   for j:=1 to anz_keywords do
-                     if keyword_token[j]=i then
-                       syntaxerror(keyword[j])
-                end;
-           end
-         else
-           begin
-             if assigned(tokeninfo) then
-               dispose(tokeninfo);
-             tokeninfo:=yylex;
-             token:=tokeninfo^.token;
-           end;
 {$endif UseTokenInfo}
+             token:=yylex;
+           end;
       end;
 
     procedure consume_all_until(atoken : ttoken);
@@ -212,7 +194,7 @@ unit pbase;
            sc^.insert(pattern);
 {$else UseTokenInfo}
            sc^.insert_with_tokeninfo(pattern,
-             tokeninfo^.fi);
+             tokenpos);
 {$endif UseTokenInfo}
            consume(ID);
            if token=COMMA then consume(COMMA)
@@ -268,7 +250,15 @@ end.
 
 {
   $Log$
-  Revision 1.4  1998-04-30 15:59:41  pierre
+  Revision 1.5  1998-05-06 08:38:44  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.4  1998/04/30 15:59:41  pierre
     * GDB works again better :
       correct type info in one pass
     + UseTokenInfo for better source position

compiler/pexpr.pas

@@ -655,12 +655,32 @@ 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
+             begin
+                if assigned(p1) then
+                  set_tree_filepos(p1,filepos);
+                oldp1:=p1;
+                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
@@ -885,6 +905,9 @@ unit pexpr;
                         else again:=false;
                      end;
                 end;
+{$ifdef UseTokenInfo}
+             check_tokenpos;
+{$endif UseTokenInfo}
            end;
       end;
 
@@ -910,6 +933,10 @@ unit pexpr;
          actprocsym : pprocsym;
 
       begin
+{$ifdef UseTokenInfo}
+         oldp1:=nil;
+         filepos:=tokenpos;
+{$endif UseTokenInfo}
          case token of
             ID:
               begin
@@ -1492,6 +1519,9 @@ unit pexpr;
               end;
          end;
          factor:=p1;
+{$ifdef UseTokenInfo}
+         check_tokenpos;
+{$endif UseTokenInfo}
       end;
 
     type    Toperator_precedence=(opcompare,opaddition,opmultiply);
@@ -1529,6 +1559,10 @@ unit pexpr;
 
     var p1,p2:Ptree;
         oldt:Ttoken;
+{$ifdef UseTokenInfo}
+         filepos : tfileposinfo;
+{$endif UseTokenInfo}
+
 
     begin
 {        if pred_level=high(Toperator_precedence) then }
@@ -1543,6 +1577,10 @@ 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 }
                     if pred_level=opmultiply then
@@ -1550,6 +1588,10 @@ 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
                 break;
@@ -1574,12 +1616,20 @@ 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);
@@ -1632,6 +1682,10 @@ unit pexpr;
                          end;
          end;
          afterassignment:=oldafterassignment;
+{$ifdef UseTokenInfo}
+         if p1<>oldp1 then
+           set_tree_filepos(p1,filepos);
+{$endif UseTokenInfo}
          expr:=p1;
       end;
 
@@ -1681,7 +1735,15 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.12  1998-05-05 12:05:42  florian
+  Revision 1.13  1998-05-06 08:38:45  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.12  1998/05/05 12:05:42  florian
     * problems with properties fixed
     * crash fixed:  i:=l when i and l are undefined, was a problem with
       implementation of private/protected

compiler/pstatmnt.pas

@@ -61,6 +61,9 @@ unit pstatmnt;
        { read assembler tokens                                        }
        ,pbase,pexpr,pdecl;
 
+    const
+
+      statement_level : longint = 0;
 
     function statement : ptree;forward;
 
@@ -177,6 +180,7 @@ unit pstatmnt;
            Message(parser_e_ordinal_expected);
 
          consume(_OF);
+         inc(statement_level);
          wurzel:=nil;
          ranges:=false;
          instruc:=nil;
@@ -242,6 +246,7 @@ unit pstatmnt;
               elseblock:=nil;
               consume(_END);
            end;
+         dec(statement_level);
 
          code:=gencasenode(caseexpr,instruc,wurzel);
 
@@ -258,6 +263,8 @@ unit pstatmnt;
       begin
          consume(_REPEAT);
          first:=nil;
+         inc(statement_level);
+
          while token<>_UNTIL do
            begin
               if first=nil then
@@ -277,6 +284,8 @@ unit pstatmnt;
                 consume(SEMICOLON);
            end;
          consume(_UNTIL);
+         dec(statement_level);
+
          first:=gensinglenode(blockn,first);
          p_e:=comp_expr(true);
          repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
@@ -454,6 +463,8 @@ unit pstatmnt;
          { read statements to try }
          consume(_TRY);
          first:=nil;
+         inc(statement_level);
+
          while (token<>_FINALLY) and (token<>_EXCEPT) do
            begin
               if first=nil then
@@ -478,6 +489,8 @@ unit pstatmnt;
               consume(_FINALLY);
               p_finally_block:=statements_til_end;
               try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block);
+              dec(statement_level);
+
            end
          else
            begin
@@ -519,6 +532,8 @@ unit pstatmnt;
                 begin
                    p_default:=statements_til_end;
                 end;
+              dec(statement_level);
+
               in_except_block:=old_in_except_block;
               try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false);
            end;
@@ -783,10 +798,18 @@ 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);
+
          while token<>_END do
            begin
               if first=nil then
@@ -816,8 +839,14 @@ unit pstatmnt;
               emptystats;
            end;
          consume(_END);
+         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;
 
@@ -836,7 +865,7 @@ unit pstatmnt;
 
       begin
 {$ifdef UseTokenInfo}
-         filepos:=tokeninfo^.fi;
+         filepos:=tokenpos;
 {$endif UseTokenInfo}
          case token of
             _GOTO : begin
@@ -993,7 +1022,9 @@ unit pstatmnt;
                    { as it is handled differently }
                    funcretsym^._name:=strpnew('func_result');
 {$else  TEST_FUNCRET }
-                   procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
+                   { align func result at 4 byte }
+                   procinfo.retoffset:=
+                     -((-procinfo.firsttemp+(procinfo.retdef^.size+3)) div 4)*4;
                    procinfo.firsttemp:=procinfo.retoffset;
 {$endif TEST_FUNCRET }
                    if (procinfo.flags and pi_operator)<>0 then
@@ -1052,7 +1083,7 @@ unit pstatmnt;
                    usedinproc:=usedinproc or ($800 shr word(R_D0))
 {$endif}
                 end
-              else
+              else if not is_fpu(procinfo.retdef) then
               { should we allow assembler functions of big elements ? }
                Message(parser_e_asm_incomp_with_function_return);
            end;
@@ -1068,8 +1099,8 @@ unit pstatmnt;
                   procinfo.framepointer:=R_SP;
 {$endif}
                   { set the right value for parameters }
-                  dec(aktprocsym^.definition^.parast^.call_offset,4);
+                  dec(aktprocsym^.definition^.parast^.call_offset,sizeof(pointer));
-                  dec(procinfo.call_offset,4);
+                  dec(procinfo.call_offset,sizeof(pointer));
               end;
             assembler_block:=_asm_statement;
           end;
@@ -1077,7 +1108,15 @@ unit pstatmnt;
 end.
 {
   $Log$
-  Revision 1.8  1998-05-05 12:05:42  florian
+  Revision 1.9  1998-05-06 08:38:46  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.8  1998/05/05 12:05:42  florian
     * problems with properties fixed
     * crash fixed:  i:=l when i and l are undefined, was a problem with
       implementation of private/protected

compiler/scanner.pas

@@ -161,21 +161,18 @@ unit scanner;
 
 
 {$ifdef UseTokenInfo}
-    type
+{    type
       ttokeninfo = record
                  token : ttoken;
                  fi : tfileposinfo;
                  end;
-      ptokeninfo = ^ttokeninfo;
+      ptokeninfo = ^ttokeninfo; }
+      var tokenpos : tfileposinfo;
 {$endif UseTokenInfo}
 
       {public}
         procedure syntaxerror(const s : string);
-{$ifndef UseTokenInfo}
         function yylex : ttoken;
-{$else UseTokenInfo}
-        function yylex : ptokeninfo;
-{$endif UseTokenInfo}
         function asmgetchar : char;
         function get_current_col : longint;
         procedure get_cur_file_pos(var fileinfo : tfileposinfo);
@@ -667,16 +664,11 @@ unit scanner;
       end;
 
 
-{$ifndef UseTokenInfo}
         function yylex : ttoken;
-{$else UseTokenInfo}
-        function yylex : ptokeninfo;
-{$endif UseTokenInfo}
      var
         y    : ttoken;
 {$ifdef UseTokenInfo}
-        newyylex : ptokeninfo;
+        fileindex,line,column : longint;
-        line,column : longint;
 {$endif UseTokenInfo}
         code : word;
         l    : longint;
@@ -691,6 +683,7 @@ unit scanner;
 {$ifdef UseTokenInfo}
         line:=current_module^.current_inputfile^.line_no;
         column:=get_current_col;
+        fileindex:=current_module^.current_index;
 {$endif UseTokenInfo}
         { was the last character a point ? }
         { this code is needed because the scanner if there is a 1. found if  }
@@ -708,10 +701,10 @@ unit scanner;
              yylex:=POINT;
              exit;
 {$else UseTokenInfo}
-                  y:=POINTPOINT;
+                  yylex:=POINTPOINT;
                   goto exit_label;
                end;
-             y:=POINT;
+             yylex:=POINT;
              goto exit_label;
 {$endif UseTokenInfo}
           end;
@@ -729,6 +722,7 @@ unit scanner;
 {$ifdef UseTokenInfo}
         line:=current_module^.current_inputfile^.line_no;
         column:=get_current_col;
+        fileindex:=current_module^.current_index;
         { will become line:=lasttokenpos ??;}
 {$endif UseTokenInfo}
         case c of
@@ -737,9 +731,7 @@ unit scanner;
                         orgpattern:=readstring;
                         pattern:=upper(orgpattern);
                         if (length(pattern) in [2..id_len]) and is_keyword(y) then
-{$ifndef UseTokenInfo}
                          yylex:=y
-{$endif UseTokenInfo}
                         else
                          begin
                          { this takes some time ... }
@@ -786,33 +778,29 @@ unit scanner;
                                  exit;
                                end;
                             end;
-{$ifndef UseTokenInfo}
                            yylex:=ID;
                          end;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                           y:=ID;
-                         end;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 '$' : begin
                          pattern:=readnumber;
-{$ifndef UseTokenInfo}
                          yylex:=INTCONST;
+{$ifndef UseTokenInfo}
                          exit;
 {$else UseTokenInfo}
-                         y:=INTCONST;
                          goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 '%' : begin
                          pattern:=readnumber;
-{$ifndef UseTokenInfo}
                          yylex:=INTCONST;
+{$ifndef UseTokenInfo}
                          exit;
 {$else UseTokenInfo}
-                         y:=INTCONST;
                          goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -824,11 +812,10 @@ unit scanner;
                                  if not(c in ['0'..'9']) then
                                   begin
                                     s_point:=true;
-{$ifndef UseTokenInfo}
                                     yylex:=INTCONST;
+{$ifndef UseTokenInfo}
                                     exit;
 {$else UseTokenInfo}
-                                    y:=INTCONST;
                                     goto exit_label;
 {$endif UseTokenInfo}
                                   end;
@@ -838,11 +825,10 @@ unit scanner;
                                     pattern:=pattern+c;
                                     readchar;
                                   end;
-{$ifndef UseTokenInfo}
                                  yylex:=REALNUMBER;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=REALNUMBER;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
@@ -861,50 +847,45 @@ unit scanner;
                                     pattern:=pattern+c;
                                     readchar;
                                   end;
-{$ifndef UseTokenInfo}
                                  yylex:=REALNUMBER;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=REALNUMBER;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                         end;
-{$ifndef UseTokenInfo}
                         yylex:=INTCONST;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=INTCONST;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 ';' : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=SEMICOLON;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=SEMICOLON;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 '[' : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=LECKKLAMMER;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=LECKKLAMMER;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 ']' : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=RECKKLAMMER;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=RECKKLAMMER;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -920,21 +901,19 @@ unit scanner;
 {$endif TP}
                            exit;
                          end;
-{$ifndef UseTokenInfo}
                         yylex:=LKLAMMER;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=LKLAMMER;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 ')' : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=RKLAMMER;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=RKLAMMER;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -943,19 +922,17 @@ unit scanner;
                         if (c='=') and c_like_operators then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=_PLUSASN;
+{$ifndef UseTokenInfo}
                            exit;
 {$else UseTokenInfo}
-                           y:=_PLUSASN;
                            goto exit_label;
 {$endif UseTokenInfo}
                          end;
-{$ifndef UseTokenInfo}
                         yylex:=PLUS;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=PLUS;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -964,19 +941,17 @@ unit scanner;
                         if (c='=') and c_like_operators then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=_MINUSASN;
+{$ifndef UseTokenInfo}
                            exit;
 {$else UseTokenInfo}
-                           y:=_MINUSASN;
                            goto exit_label;
 {$endif UseTokenInfo}
                          end;
-{$ifndef UseTokenInfo}
                         yylex:=MINUS;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=MINUS;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -985,19 +960,17 @@ unit scanner;
                         if c='=' then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=ASSIGNMENT;
+{$ifndef UseTokenInfo}
                            exit;
 {$else UseTokenInfo}
-                           y:=ASSIGNMENT;
                            goto exit_label;
 {$endif UseTokenInfo}
                          end;
-{$ifndef UseTokenInfo}
                         yylex:=COLON;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=COLON;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1006,26 +979,17 @@ unit scanner;
                         if (c='=') and c_like_operators then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=_STARASN;
-{$else UseTokenInfo}
-                           y:=_STARASN;
-{$endif UseTokenInfo}
                          end else if c='*' then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=STARSTAR;
-{$else UseTokenInfo}
-                           y:=STARSTAR;
-{$endif UseTokenInfo}
                          end
                         else
-{$ifndef UseTokenInfo}
                           yylex:=STAR;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                          y:=STAR;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1036,11 +1000,10 @@ unit scanner;
                                  if c_like_operators then
                                   begin
                                     readchar;
-{$ifndef UseTokenInfo}
                                     yylex:=_SLASHASN;
+{$ifndef UseTokenInfo}
                                     exit;
 {$else UseTokenInfo}
-                                    y:=_SLASHASN;
                                     goto exit_label;
 {$endif UseTokenInfo}
                                   end;
@@ -1055,21 +1018,19 @@ unit scanner;
                                  exit;
                                end;
                         end;
-{$ifndef UseTokenInfo}
                         yylex:=SLASH;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=SLASH;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
            '='      : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=EQUAL;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=EQUAL;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1078,20 +1039,18 @@ unit scanner;
                         if c='.' then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=POINTPOINT;
+{$ifndef UseTokenInfo}
                            exit;
 {$else UseTokenInfo}
-                           y:=POINTPOINT;
                            goto exit_label;
 {$endif UseTokenInfo}
                          end
                         else
-{$ifndef UseTokenInfo}
                          yylex:=POINT;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                         y:=POINT;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1100,28 +1059,22 @@ unit scanner;
                         if c='@' then
                          begin
                            readchar;
-{$ifndef UseTokenInfo}
                            yylex:=DOUBLEADDR;
-{$else UseTokenInfo}
-                           y:=DOUBLEADDR;
-{$endif UseTokenInfo}
                          end
                         else
-{$ifndef UseTokenInfo}
                          yylex:=KLAMMERAFFE;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                         y:=KLAMMERAFFE;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 ',' : begin
                         readchar;
-{$ifndef UseTokenInfo}
                         yylex:=COMMA;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=COMMA;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1138,11 +1091,10 @@ unit scanner;
                             end
                            else
                             begin
-{$ifndef UseTokenInfo}
                               yylex:=CARET;
+{$ifndef UseTokenInfo}
                               exit;
 {$else UseTokenInfo}
-                              y:=CARET;
                               goto exit_label;
 {$endif UseTokenInfo}
                             end;
@@ -1187,17 +1139,13 @@ unit scanner;
                           end;
                         until false;
                       { strings with length 1 become const chars }
-{$ifndef UseTokenInfo}
                         if length(pattern)=1 then
                          yylex:=CCHAR
                         else
                          yylex:=CSTRING;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        if length(pattern)=1 then
-                         y:=CCHAR
-                        else
-                         y:=CSTRING;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1206,40 +1154,36 @@ unit scanner;
                         case c of
                          '=' : begin
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=GTE;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=GTE;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                          '>' : begin
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=_SHR;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=_SHR;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                          '<' : begin { >< is for a symetric diff for sets }
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=SYMDIF;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=SYMDIF;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                         end;
-{$ifndef UseTokenInfo}
                         yylex:=GT;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=GT;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1248,49 +1192,44 @@ unit scanner;
                         case c of
                          '>' : begin
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=UNEQUAL;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=UNEQUAL;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                          '=' : begin
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=LTE;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=LTE;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                          '<' : begin
                                  readchar;
-{$ifndef UseTokenInfo}
                                  yylex:=_SHL;
+{$ifndef UseTokenInfo}
                                  exit;
 {$else UseTokenInfo}
-                                 y:=_SHL;
                                  goto exit_label;
 {$endif UseTokenInfo}
                                end;
                         end;
-{$ifndef UseTokenInfo}
                         yylex:=LT;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=LT;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
                 #26 : begin
-{$ifndef UseTokenInfo}
                         yylex:=_EOF;
+{$ifndef UseTokenInfo}
                         exit;
 {$else UseTokenInfo}
-                        y:=_EOF;
                         goto exit_label;
 {$endif UseTokenInfo}
                       end;
@@ -1301,12 +1240,9 @@ unit scanner;
            end;
 {$ifdef UseTokenInfo}
       exit_label:
-        new(newyylex);
+        tokenpos.fileindex:=fileindex;
-        newyylex^.token:=y;
+        tokenpos.line:=line;
-        newyylex^.fi.fileindex:=current_module^.current_index;
+        tokenpos.column:=column;
-        newyylex^.fi.line:=line;
-        newyylex^.fi.column:=column;
-        yylex:=newyylex;
 {$endif UseTokenInfo}
      end;
 
@@ -1461,7 +1397,15 @@ unit scanner;
 end.
 {
   $Log$
-  Revision 1.16  1998-05-04 17:54:28  peter
+  Revision 1.17  1998-05-06 08:38:47  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.16  1998/05/04 17:54:28  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

compiler/systems.pas

@@ -45,6 +45,9 @@ unit systems;
        {$ifdef i386}
               ,link_ldgo32v1, link_ldgo32v2, link_ldw, link_ldos2);
        {$endif i386}
+       {$ifdef m68k}
+              );
+       {$endif}
 
        tendian = (endian_little,en_big_endian);
 
@@ -516,7 +519,15 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  1998-05-04 20:19:54  peter
+  Revision 1.9  1998-05-06 08:38:49  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.8  1998/05/04 20:19:54  peter
     * small fix for go32v2
 
   Revision 1.7  1998/05/04 17:54:29  peter

compiler/tree.pas

@@ -46,6 +46,7 @@ unit tree;
 
        pconstset = ^tconstset;
 
+
        ttreetyp = (addn,            {Represents the + operator.}
                    muln,            {Represents the * operator.}
                    subn,            {Represents the - operator.}
@@ -284,8 +285,8 @@ unit tree;
     procedure set_file_line(from,_to : ptree);
     procedure set_current_file_line(_to : ptree);
     procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
-
 {$ifdef extdebug}
+    procedure compare_trees(p1,p2 : ptree);
     const
        maxfirstpasscount : longint = 0;
 {$endif extdebug}
@@ -295,7 +296,13 @@ unit tree;
   implementation
 
 {$ifdef UseTokenInfo}
-    uses pbase;
+{$ifdef extdebug}
+    uses
+       types,pbase;
+{$else extdebug}
+    uses
+       pbase;
+{$endif extdebug}
 {$endif UseTokenInfo}
 
 {****************************************************************************
@@ -349,13 +356,10 @@ unit tree;
 
          { we know also the position }
 {$ifdef UseTokenInfo}
-         if assigned(tokeninfo) then
+         hp^.fileinfo:=tokenpos;
-           begin
+{$else UseTokenInfo}
-              hp^.fileinfo:=tokeninfo^.fi;
+         get_cur_file_pos(hp^.fileinfo);
-           end
-         else
 {$endif UseTokenInfo}
-           get_cur_file_pos(hp^.fileinfo);
          hp^.pragmas:=aktswitches;
          getnode:=hp;
       end;
@@ -1167,6 +1171,263 @@ unit tree;
          gensetconstruktnode:=p;
       end;
 
+{$ifdef extdebug}
+    procedure compare_trees(p1,p2 : ptree);
+
+      var
+         error_found : boolean;
+
+      begin
+         if p1^.error<>p2^.error then
+           begin
+              comment(v_warning,'error field different');
+              error_found:=true;
+           end;
+         if p1^.disposetyp<>p2^.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
+           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
+           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
+           begin
+              comment(v_warning,'registers32 field different');
+              comment(v_warning,tostr(p1^.registers32)+'<>'+tostr(p2^.registers32));
+              error_found:=true;
+           end;
+          if p1^.registersfpu<>p2^.registersfpu then
+           begin
+              comment(v_warning,'registersfpu field different');
+              error_found:=true;
+           end;
+{$ifdef SUPPORT_MMX}
+          if p1^.registersmmx<>p2^.registersmmx then
+           begin
+              comment(v_warning,'registersmmx field different');
+              error_found:=true;
+           end;
+{$endif SUPPORT_MMX}
+          if p1^.left<>p2^.left then
+           begin
+              comment(v_warning,'left field different');
+              error_found:=true;
+           end;
+          if p1^.right<>p2^.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
+            begin
+               comment(v_warning,'fileinfo.line field different');
+               error_found:=true;
+            end;
+          if p1^.fileinfo.column<>p2^.fileinfo.column then
+            begin
+               comment(v_warning,'fileinfo.column field different');
+               error_found:=true;
+            end;
+          if p1^.fileinfo.fileindex<>p2^.fileinfo.fileindex then
+            begin
+               comment(v_warning,'fileinfo.fileindex field different');
+               error_found:=true;
+            end;
+          if p1^.pragmas<>p2^.pragmas then
+            begin
+               comment(v_warning,'pragmas field different');
+               error_found:=true;
+            end;
+{$ifdef extdebug}
+          if p1^.firstpasscount<>p2^.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
+             addn :
+             begin
+                if p1^.use_strconcat<>p2^.use_strconcat then
+                  begin
+                     comment(v_warning,'use_strconcat field different');
+                     error_found:=true;
+                  end;
+                if p1^.string_typ<>p2^.string_typ then
+                  begin
+                     comment(v_warning,'stringtyp field different');
+                     error_found:=true;
+                  end;
+             end;
+             callparan :
+             {(is_colon_para : boolean;exact_match_found : boolean);}
+             begin
+                if p1^.is_colon_para<>p2^.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
+                  begin
+                     comment(v_warning,'exact_match_found field different');
+                     error_found:=true;
+                  end;
+             end;
+             assignn :
+             {(assigntyp : tassigntyp;concat_string : boolean);}
+             begin
+                if p1^.assigntyp<>p2^.assigntyp then
+                  begin
+                     comment(v_warning,'assigntyp field different');
+                     error_found:=true;
+                  end;
+                if p1^.concat_string<>p2^.concat_string then
+                  begin
+                     comment(v_warning,'concat_string field different');
+                     error_found:=true;
+                  end;
+             end;
+             loadn :
+             {(symtableentry : psym;symtable : psymtable;
+                      is_absolute,is_first : boolean);}
+             begin
+                if p1^.symtableentry<>p2^.symtableentry then
+                  begin
+                     comment(v_warning,'symtableentry field different');
+                     error_found:=true;
+                  end;
+                if p1^.symtable<>p2^.symtable then
+                  begin
+                     comment(v_warning,'symtable field different');
+                     error_found:=true;
+                  end;
+                if p1^.is_absolute<>p2^.is_absolute then
+                  begin
+                     comment(v_warning,'is_absolute field different');
+                     error_found:=true;
+                  end;
+                if p1^.is_first<>p2^.is_first then
+                  begin
+                     comment(v_warning,'is_first field different');
+                     error_found:=true;
+                  end;
+             end;
+             calln :
+             {(symtableprocentry : pprocsym;
+                      symtableproc : psymtable;procdefinition : pprocdef;
+                      methodpointer : ptree;
+                      no_check,unit_specific : boolean);}
+             begin
+                if p1^.symtableprocentry<>p2^.symtableprocentry then
+                  begin
+                     comment(v_warning,'symtableprocentry field different');
+                     error_found:=true;
+                  end;
+                if p1^.symtableproc<>p2^.symtableproc then
+                  begin
+                     comment(v_warning,'symtableproc field different');
+                     error_found:=true;
+                  end;
+                if p1^.procdefinition<>p2^.procdefinition then
+                  begin
+                     comment(v_warning,'procdefinition field different');
+                     error_found:=true;
+                  end;
+                if p1^.methodpointer<>p2^.methodpointer then
+                  begin
+                     comment(v_warning,'methodpointer field different');
+                     error_found:=true;
+                  end;
+                if p1^.no_check<>p2^.no_check then
+                  begin
+                     comment(v_warning,'no_check field different');
+                     error_found:=true;
+                  end;
+                if p1^.unit_specific<>p2^.unit_specific then
+                  begin
+                     error_found:=true;
+                     comment(v_warning,'unit_specific field different');
+                  end;
+             end;
+             ordconstn :
+               begin
+                  if p1^.value<>p2^.value then
+                  begin
+                     comment(v_warning,'value field different');
+                     error_found:=true;
+                  end;
+               end;
+             realconstn :
+               begin
+                  if p1^.valued<>p2^.valued then
+                  begin
+                     comment(v_warning,'valued field different');
+                     error_found:=true;
+                  end;
+                  if p1^.labnumber<>p2^.labnumber then
+                  begin
+                     comment(v_warning,'labnumber field different');
+                     error_found:=true;
+                  end;
+                  if p1^.realtyp<>p2^.realtyp then
+                  begin
+                     comment(v_warning,'realtyp field different');
+                     error_found:=true;
+                  end;
+               end;
+             (*realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
+             fixconstn : (valuef: longint);
+{$ifdef TEST_FUNCRET}
+             funcretn : (funcretprocinfo : pointer;retdef : pdef);
+{$endif TEST_FUNCRET}
+             subscriptn : (vs : pvarsym);
+             vecn : (memindex,memseg:boolean);
+             { stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
+             { string const can be longer then 255 with ansistring !! }
+{$ifdef UseAnsiString}
+             stringconstn : (values : pchar;length : longint; labstrnumber : longint);
+{$else UseAnsiString}
+             stringconstn : (values : pstring; labstrnumber : longint);
+{$endif UseAnsiString}
+             typeconvn : (convtyp : tconverttype;explizit : boolean);
+             inlinen : (inlinenumber : longint);
+             procinlinen : (inlineprocdef : pprocdef);
+             setconstrn : (constset : pconstset);
+             loopn : (t1,t2 : ptree;backward : boolean);
+             asmn : (p_asm : paasmoutput);
+             casen : (nodes : pcaserecord;elseblock : ptree);
+             labeln,goton : (labelnr : plabel);
+             withn : (withsymtable : psymtable;tablecount : longint);
+           end; *)
+           end;
+         if not error_found then
+           comment(v_warning,'did not find difference in trees');
+
+      end;
+{$endif extdebug}
+
     function equal_trees(t1,t2 : ptree) : boolean;
 
       begin
@@ -1263,7 +1524,15 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.5  1998-04-30 15:59:43  pierre
+  Revision 1.6  1998-05-06 08:38:52  pierre
+    * better position info with UseTokenInfo
+      UseTokenInfo greatly simplified
+    + added check for changed tree after first time firstpass
+      (if we could remove all the cases were it happen
+      we could skip all firstpass if firstpasscount > 1)
+      Only with ExtDebug
+
+  Revision 1.5  1998/04/30 15:59:43  pierre
     * GDB works again better :
       correct type info in one pass
     + UseTokenInfo for better source position