* obsolete files

compiler/old/cg386add.pas

@@ -1,2409 +0,0 @@
- {
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for in add node
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386add;
-
-{$i defines.inc}
-
-interface
-
-{$define usecreateset}
-
-    uses
-      tree;
-
-    procedure secondadd(var p : ptree);
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386;
-
-{*****************************************************************************
-                                Helpers
-*****************************************************************************}
-
-    function getresflags(p : ptree;unsigned : boolean) : tresflags;
-
-      begin
-         if not(unsigned) then
-           begin
-              if p^.swaped then
-                case p^.treetype of
-                   equaln : getresflags:=F_E;
-                   unequaln : getresflags:=F_NE;
-                   ltn : getresflags:=F_G;
-                   lten : getresflags:=F_GE;
-                   gtn : getresflags:=F_L;
-                   gten : getresflags:=F_LE;
-                end
-              else
-                case p^.treetype of
-                   equaln : getresflags:=F_E;
-                   unequaln : getresflags:=F_NE;
-                   ltn : getresflags:=F_L;
-                   lten : getresflags:=F_LE;
-                   gtn : getresflags:=F_G;
-                   gten : getresflags:=F_GE;
-                end;
-           end
-         else
-           begin
-              if p^.swaped then
-                case p^.treetype of
-                   equaln : getresflags:=F_E;
-                   unequaln : getresflags:=F_NE;
-                   ltn : getresflags:=F_A;
-                   lten : getresflags:=F_AE;
-                   gtn : getresflags:=F_B;
-                   gten : getresflags:=F_BE;
-                end
-              else
-                case p^.treetype of
-                   equaln : getresflags:=F_E;
-                   unequaln : getresflags:=F_NE;
-                   ltn : getresflags:=F_B;
-                   lten : getresflags:=F_BE;
-                   gtn : getresflags:=F_A;
-                   gten : getresflags:=F_AE;
-                end;
-           end;
-      end;
-
-
-    procedure SetResultLocation(cmpop,unsigned:boolean;var p :ptree);
-
-      begin
-         { remove temporary location if not a set or string }
-         { that's a bad hack (FK) who did this ?            }
-         if (p^.left^.resulttype^.deftype<>stringdef) and
-            ((p^.left^.resulttype^.deftype<>setdef) or (psetdef(p^.left^.resulttype)^.settype=smallset)) and
-            (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-           ungetiftemp(p^.left^.location.reference);
-         if (p^.right^.resulttype^.deftype<>stringdef) and
-            ((p^.right^.resulttype^.deftype<>setdef) or (psetdef(p^.right^.resulttype)^.settype=smallset)) and
-            (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-           ungetiftemp(p^.right^.location.reference);
-         { in case of comparison operation the put result in the flags }
-         if cmpop then
-           begin
-              clear_location(p^.location);
-              p^.location.loc:=LOC_FLAGS;
-              p^.location.resflags:=getresflags(p,unsigned);
-           end;
-      end;
-
-
-{*****************************************************************************
-                                Addstring
-*****************************************************************************}
-
-    procedure addstring(var p : ptree);
-      var
-{$ifdef newoptimizations2}
-        l: pasmlabel;
-        hreg: tregister;
-        href2: preference;
-        oldregisterdef: boolean;
-{$endif newoptimizations2}
-        pushedregs : tpushed;
-        href       : treference;
-        pushed,
-        cmpop      : boolean;
-        regstopush : byte;
-      begin
-        { string operations are not commutative }
-        if p^.swaped then
-          swaptree(p);
-        case pstringdef(p^.left^.resulttype)^.string_typ of
-           st_ansistring:
-             begin
-                case p^.treetype of
-                   addn:
-                     begin
-                        cmpop:=false;
-                        secondpass(p^.left);
-                        { to avoid problem with maybe_push and restore }
-                        set_location(p^.location,p^.left^.location);
-                        pushed:=maybe_push(p^.right^.registers32,p,false);
-                        secondpass(p^.right);
-                        if pushed then
-                          begin
-                             restore(p,false);
-                             set_location(p^.left^.location,p^.location);
-                          end;
-                        { get the temp location, must be done before regs are
-                          released/pushed because after the release the regs are
-                          still used for the push (PFV) }
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_MEM;
-                        gettempansistringreference(p^.location.reference);
-                        decrstringref(cansistringdef,p^.location.reference);
-                        { release used registers }
-                        del_location(p^.right^.location);
-                        del_location(p^.left^.location);
-                        { push the still used registers }
-                        pushusedregisters(pushedregs,$ff);
-                        { push data }
-                        emitpushreferenceaddr(p^.location.reference);
-                        emit_push_loc(p^.right^.location);
-                        emit_push_loc(p^.left^.location);
-                        emitcall('FPC_ANSISTR_CONCAT');
-                        popusedregisters(pushedregs);
-                        maybe_loadesi;
-                        ungetiftempansi(p^.left^.location.reference);
-                        ungetiftempansi(p^.right^.location.reference);
-                     end;
-                   ltn,lten,gtn,gten,
-                   equaln,unequaln:
-                     begin
-                        cmpop:=true;
-                        if (p^.treetype in [equaln,unequaln]) and
-                           (p^.left^.treetype=stringconstn) and
-                           (p^.left^.length=0) then
-                          begin
-                             secondpass(p^.right);
-                             { release used registers }
-                             del_location(p^.right^.location);
-                             del_location(p^.left^.location);
-                             case p^.right^.location.loc of
-                               LOC_REFERENCE,LOC_MEM:
-                                 emit_const_ref(A_CMP,S_L,0,newreference(p^.right^.location.reference));
-                               LOC_REGISTER,LOC_CREGISTER:
-                                 emit_const_reg(A_CMP,S_L,0,p^.right^.location.register);
-                             end;
-                             ungetiftempansi(p^.left^.location.reference);
-                             ungetiftempansi(p^.right^.location.reference);
-                          end
-                        else if (p^.treetype in [equaln,unequaln]) and
-                          (p^.right^.treetype=stringconstn) and
-                          (p^.right^.length=0) then
-                          begin
-                             secondpass(p^.left);
-                             { release used registers }
-                             del_location(p^.right^.location);
-                             del_location(p^.left^.location);
-                             case p^.right^.location.loc of
-                               LOC_REFERENCE,LOC_MEM:
-                                 emit_const_ref(A_CMP,S_L,0,newreference(p^.left^.location.reference));
-                               LOC_REGISTER,LOC_CREGISTER:
-                                 emit_const_reg(A_CMP,S_L,0,p^.left^.location.register);
-                             end;
-                             ungetiftempansi(p^.left^.location.reference);
-                             ungetiftempansi(p^.right^.location.reference);
-                          end
-                        else
-                          begin
-                             secondpass(p^.left);
-                             pushed:=maybe_push(p^.right^.registers32,p^.left,false);
-                             secondpass(p^.right);
-                             if pushed then
-                               restore(p^.left,false);
-                             { release used registers }
-                             del_location(p^.right^.location);
-                             del_location(p^.left^.location);
-                             { push the still used registers }
-                             pushusedregisters(pushedregs,$ff);
-                             { push data }
-                             case p^.right^.location.loc of
-                               LOC_REFERENCE,LOC_MEM:
-                                 emit_push_mem(p^.right^.location.reference);
-                               LOC_REGISTER,LOC_CREGISTER:
-                                 emit_reg(A_PUSH,S_L,p^.right^.location.register);
-                             end;
-                             case p^.left^.location.loc of
-                               LOC_REFERENCE,LOC_MEM:
-                                 emit_push_mem(p^.left^.location.reference);
-                               LOC_REGISTER,LOC_CREGISTER:
-                                 emit_reg(A_PUSH,S_L,p^.left^.location.register);
-                             end;
-                             emitcall('FPC_ANSISTR_COMPARE');
-                             emit_reg_reg(A_OR,S_L,R_EAX,R_EAX);
-                             popusedregisters(pushedregs);
-                             maybe_loadesi;
-                             ungetiftempansi(p^.left^.location.reference);
-                             ungetiftempansi(p^.right^.location.reference);
-                          end;
-                     end;
-                end;
-               { the result of ansicompare is signed }
-               SetResultLocation(cmpop,false,p);
-             end;
-           st_shortstring:
-             begin
-                case p^.treetype of
-                   addn:
-                     begin
-                        cmpop:=false;
-                        secondpass(p^.left);
-                        { if str_concat is set in expr
-                          s:=s+ ... no need to create a temp string (PM) }
-
-                        if (p^.left^.treetype<>addn) and not (p^.use_strconcat) then
-                          begin
-
-                             { can only reference be }
-                             { string in register would be funny    }
-                             { therefore produce a temporary string }
-
-                             gettempofsizereference(256,href);
-                             copyshortstring(href,p^.left^.location.reference,255,false,true);
-                             { release the registers }
-{                             done by copyshortstring now (JM)           }
-{                             del_reference(p^.left^.location.reference); }
-                             ungetiftemp(p^.left^.location.reference);
-
-                             { does not hurt: }
-                             clear_location(p^.left^.location);
-                             p^.left^.location.loc:=LOC_MEM;
-                             p^.left^.location.reference:=href;
-
-{$ifdef newoptimizations2}
-                             { length of temp string = 255 (JM) }
-                             { *** redefining a type is not allowed!! (thanks, Pierre) }
-                             { also problem with constant string!                      }
-                             pstringdef(p^.left^.resulttype)^.len := 255;
-
-{$endif newoptimizations2}
-                          end;
-
-                        secondpass(p^.right);
-
-{$ifdef newoptimizations2}
-                        { special case for string := string + char (JM) }
-                        { needs string length stuff from above!         }
-                        hreg := R_NO;
-                        if is_shortstring(p^.left^.resulttype) and
-                           is_char(p^.right^.resulttype) then
-                          begin
-                            getlabel(l);
-                            getexplicitregister32(R_EDI);
-                            { load the current string length }
-                            emit_ref_reg(A_MOVZX,S_BL,
-                              newreference(p^.left^.location.reference),R_EDI);
-                            { is it already maximal? }
-                            emit_const_reg(A_CMP,S_L,
-                              pstringdef(p^.left^.resulttype)^.len,R_EDI);
-                            emitjmp(C_E,l);
-                            { no, so add the new character }
-                            { is it a constant char? }
-                            if (p^.right^.treetype <> ordconstn) then
-                              { no, make sure it is in a register }
-                              if p^.right^.location.loc in [LOC_REFERENCE,LOC_MEM] then
-                                begin
-                                  { free the registers of p^.right }
-                                  del_reference(p^.right^.location.reference);
-                                  { get register for the char }
-                                  hreg := reg32toreg8(getregister32);
-                                  emit_ref_reg(A_MOV,S_B,
-                                    newreference(p^.right^.location.reference),
-                                    hreg);
-                                 { I don't think a temp char exists, but it won't hurt (JM)Ê}
-                                 ungetiftemp(p^.right^.location.reference);
-                                end
-                              else hreg := p^.right^.location.register;
-                            href2 := newreference(p^.left^.location.reference);
-                            { we need a new reference to store the character }
-                            { at the end of the string. Check if the base or }
-                            { index register is still free                   }
-                            if (p^.left^.location.reference.base <> R_NO) and
-                               (p^.left^.location.reference.index <> R_NO) then
-                              begin
-                                { they're not free, so add the base reg to }
-                                { the string length (since the index can   }
-                                { have a scalefactor) and use EDI as base  }
-                                emit_reg_reg(A_ADD,S_L,
-                                  p^.left^.location.reference.base,R_EDI);
-                                href2^.base := R_EDI;
-                              end
-                            else
-                              { at least one is still free, so put EDI there }
-                              if href2^.base = R_NO then
-                                href2^.base := R_EDI
-                              else
-                                begin
-                                  href2^.index := R_EDI;
-                                  href2^.scalefactor := 1;
-                                end;
-                            { we need to be one position after the last char }
-                            inc(href2^.offset);
-                            { increase the string length }
-                            emit_ref(A_INC,S_B,newreference(p^.left^.location.reference));
-                            { and store the character at the end of the string }
-                            if (p^.right^.treetype <> ordconstn) then
-                              begin
-                                { no new_reference(href2) because it's only }
-                                { used once (JM)                            }
-                                emit_reg_ref(A_MOV,S_B,hreg,href2);
-                                ungetregister(hreg);
-                              end
-                            else
-                              emit_const_ref(A_MOV,S_B,p^.right^.value,href2);
-                            emitlab(l);
-                            ungetregister32(R_EDI);
-                          end
-                        else
-                          begin
-{$endif  newoptimizations2}
-                        { on the right we do not need the register anymore too }
-                        { Instead of releasing them already, simply do not }
-                        { push them (so the release is in the right place, }
-                        { because emitpushreferenceaddr doesn't need extra }
-                        { registers) (JM)                                  }
-                            regstopush := $ff;
-                            remove_non_regvars_from_loc(p^.right^.location,
-                              regstopush);
-                           pushusedregisters(pushedregs,regstopush);
-                           { push the maximum possible length of the result }
-{$ifdef newoptimizations2}
-                           { string (could be < 255 chars now) (JM)         }
-                            emit_const(A_PUSH,S_L,
-                              pstringdef(p^.left^.resulttype)^.len);
-{$endif newoptimizations2}
-                            emitpushreferenceaddr(p^.left^.location.reference);
-                           { the optimizer can more easily put the          }
-                           { deallocations in the right place if it happens }
-                           { too early than when it happens too late (if    }
-                           { the pushref needs a "lea (..),edi; push edi")  }
-                            del_reference(p^.right^.location.reference);
-                            emitpushreferenceaddr(p^.right^.location.reference);
-{$ifdef newoptimizations2}
-                            emitcall('FPC_SHORTSTR_CONCAT_LEN');
-{$else newoptimizations2}
-                            emitcall('FPC_SHORTSTR_CONCAT');
-{$endif newoptimizations2}
-                            ungetiftemp(p^.right^.location.reference);
-                            maybe_loadesi;
-                            popusedregisters(pushedregs);
-{$ifdef newoptimizations2}
-                        end;
-{$endif newoptimizations2}
-                        set_location(p^.location,p^.left^.location);
-                     end;
-                   ltn,lten,gtn,gten,
-                   equaln,unequaln :
-                     begin
-                        cmpop:=true;
-                        { generate better code for s='' and s<>'' }
-                        if (p^.treetype in [equaln,unequaln]) and
-                           (((p^.left^.treetype=stringconstn) and (str_length(p^.left)=0)) or
-                            ((p^.right^.treetype=stringconstn) and (str_length(p^.right)=0))) then
-                          begin
-                             secondpass(p^.left);
-                             { are too few registers free? }
-                             pushed:=maybe_push(p^.right^.registers32,p^.left,false);
-                             secondpass(p^.right);
-                             if pushed then
-                               restore(p^.left,false);
-                             { only one node can be stringconstn }
-                             { else pass 1 would have evaluted   }
-                             { this node                         }
-                             if p^.left^.treetype=stringconstn then
-                               emit_const_ref(
-                                 A_CMP,S_B,0,newreference(p^.right^.location.reference))
-                             else
-                               emit_const_ref(
-                                 A_CMP,S_B,0,newreference(p^.left^.location.reference));
-                             del_reference(p^.right^.location.reference);
-                             del_reference(p^.left^.location.reference);
-                          end
-                        else
-                          begin
-                             pushusedregisters(pushedregs,$ff);
-                             secondpass(p^.left);
-                             emitpushreferenceaddr(p^.left^.location.reference);
-                             del_reference(p^.left^.location.reference);
-                             secondpass(p^.right);
-                             emitpushreferenceaddr(p^.right^.location.reference);
-                             del_reference(p^.right^.location.reference);
-                             emitcall('FPC_SHORTSTR_COMPARE');
-                             maybe_loadesi;
-                             popusedregisters(pushedregs);
-                          end;
-                        ungetiftemp(p^.left^.location.reference);
-                        ungetiftemp(p^.right^.location.reference);
-                     end;
-                   else CGMessage(type_e_mismatch);
-                end;
-               SetResultLocation(cmpop,true,p);
-             end;
-          end;
-      end;
-
-
-{*****************************************************************************
-                                Addset
-*****************************************************************************}
-
-    procedure addset(var p : ptree);
-      var
-        createset,
-        cmpop,
-        pushed : boolean;
-        href   : treference;
-        pushedregs : tpushed;
-        regstopush: byte;
-      begin
-        cmpop:=false;
-
-        { not commutative }
-        if p^.swaped then
-         swaptree(p);
-
-        { optimize first loading of a set }
-{$ifdef usecreateset}
-        if (p^.right^.treetype=setelementn) and
-           not(assigned(p^.right^.right)) and
-           is_emptyset(p^.left) then
-         createset:=true
-        else
-{$endif}
-         begin
-           createset:=false;
-           secondpass(p^.left);
-         end;
-
-        { are too few registers free? }
-        pushed:=maybe_push(p^.right^.registers32,p^.left,false);
-        secondpass(p^.right);
-        if codegenerror then
-          exit;
-        if pushed then
-          restore(p^.left,false);
-
-        set_location(p^.location,p^.left^.location);
-
-        { handle operations }
-
-        case p^.treetype of
-          equaln,
-        unequaln
-{$IfNDef NoSetInclusion}
-        ,lten, gten
-{$EndIf NoSetInclusion}
-                  : begin
-                     cmpop:=true;
-                     del_location(p^.left^.location);
-                     del_location(p^.right^.location);
-                     pushusedregisters(pushedregs,$ff);
-{$IfNDef NoSetInclusion}
-                     If (p^.treetype in [equaln, unequaln, lten]) Then
-                       Begin
-{$EndIf NoSetInclusion}
-                         emitpushreferenceaddr(p^.right^.location.reference);
-                         emitpushreferenceaddr(p^.left^.location.reference);
-{$IfNDef NoSetInclusion}
-                       End
-                     Else  {gten = lten, if the arguments are reversed}
-                       Begin
-                         emitpushreferenceaddr(p^.left^.location.reference);
-                         emitpushreferenceaddr(p^.right^.location.reference);
-                       End;
-                     Case p^.treetype of
-                       equaln, unequaln:
-{$EndIf NoSetInclusion}
-                         emitcall('FPC_SET_COMP_SETS');
-{$IfNDef NoSetInclusion}
-                       lten, gten:
-                         Begin
-                           emitcall('FPC_SET_CONTAINS_SETS');
-                           { we need a jne afterwards, not a jnbe/jnae }
-                           p^.treetype := equaln;
-                        End;
-                     End;
-{$EndIf NoSetInclusion}
-                     maybe_loadesi;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                   end;
-            addn : begin
-                   { add can be an other SET or Range or Element ! }
-                     { del_location(p^.right^.location);
-                       done in pushsetelement below PM
-
-                     And someone added it again because those registers must
-                     not be pushed by the pushusedregisters, however this
-                     breaks the optimizer (JM)
-
-                     del_location(p^.right^.location);
-                     pushusedregisters(pushedregs,$ff);}
-
-                     regstopush := $ff;
-                     remove_non_regvars_from_loc(p^.right^.location,regstopush);
-                     remove_non_regvars_from_loc(p^.left^.location,regstopush);
-                     pushusedregisters(pushedregs,regstopush);
-                     { this is still right before the instruction that uses }
-                     { p^.left^.location, but that can be fixed by the      }
-                     { optimizer. There must never be an additional         }
-                     { between the release and the use, because that is not }
-                     { detected/fixed. As Pierre said above, p^.right^.loc  }
-                     { will be released in pushsetelement (JM)              }
-                     del_location(p^.left^.location);
-                     href.symbol:=nil;
-                     gettempofsizereference(32,href);
-                     if createset then
-                      begin
-                        pushsetelement(p^.right^.left);
-                        emitpushreferenceaddr(href);
-                        emitcall('FPC_SET_CREATE_ELEMENT');
-                      end
-                     else
-                      begin
-                      { add a range or a single element? }
-                        if p^.right^.treetype=setelementn then
-                         begin
-{$IfNDef regallocfix}
-                           concatcopy(p^.left^.location.reference,href,32,false,false);
-{$Else regallocfix}
-                           concatcopy(p^.left^.location.reference,href,32,true,false);
-{$EndIf regallocfix}
-                           if assigned(p^.right^.right) then
-                            begin
-                              pushsetelement(p^.right^.right);
-                              pushsetelement(p^.right^.left);
-                              emitpushreferenceaddr(href);
-                              emitcall('FPC_SET_SET_RANGE');
-                            end
-                           else
-                            begin
-                              pushsetelement(p^.right^.left);
-                              emitpushreferenceaddr(href);
-                              emitcall('FPC_SET_SET_BYTE');
-                            end;
-                         end
-                        else
-                         begin
-                         { must be an other set }
-                           emitpushreferenceaddr(href);
-                           emitpushreferenceaddr(p^.right^.location.reference);
-{$IfDef regallocfix}
-                           del_location(p^.right^.location);
-{$EndIf regallocfix}
-                           emitpushreferenceaddr(p^.left^.location.reference);
-{$IfDef regallocfix}
-                           del_location(p^.left^.location);
-{$EndIf regallocfix}
-                           emitcall('FPC_SET_ADD_SETS');
-                         end;
-                      end;
-                     maybe_loadesi;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                     p^.location.loc:=LOC_MEM;
-                     p^.location.reference:=href;
-                   end;
-            subn,
-         symdifn,
-            muln : begin
-                     { Find out which registers have to pushed (JM) }
-                     regstopush := $ff;
-                     remove_non_regvars_from_loc(p^.left^.location,regstopush);
-                     remove_non_regvars_from_loc(p^.right^.location,regstopush);
-                     { Push them (JM) }
-                     pushusedregisters(pushedregs,regstopush);
-                     href.symbol:=nil;
-                     gettempofsizereference(32,href);
-                     emitpushreferenceaddr(href);
-                     { Release the registers right before they're used,  }
-                     { see explanation in cgai386.pas:loadansistring for }
-                     { info why this is done right before the push (JM)  }
-                     del_location(p^.right^.location);
-                     emitpushreferenceaddr(p^.right^.location.reference);
-                     { The same here }
-                     del_location(p^.left^.location);
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                     case p^.treetype of
-                      subn : emitcall('FPC_SET_SUB_SETS');
-                   symdifn : emitcall('FPC_SET_SYMDIF_SETS');
-                      muln : emitcall('FPC_SET_MUL_SETS');
-                     end;
-                     maybe_loadesi;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                     p^.location.loc:=LOC_MEM;
-                     p^.location.reference:=href;
-                   end;
-        else
-          CGMessage(type_e_mismatch);
-        end;
-        SetResultLocation(cmpop,true,p);
-      end;
-
-
-{*****************************************************************************
-                                SecondAdd
-*****************************************************************************}
-
-    procedure secondadd(var p : ptree);
-    { is also being used for xor, and "mul", "sub, or and comparative }
-    { operators                                                }
-
-      label do_normal;
-
-      var
-         hregister,hregister2 : tregister;
-         noswap,popeax,popedx,
-         pushed,mboverflow,cmpop : boolean;
-         op,op2 : tasmop;
-         flags : tresflags;
-         otl,ofl : pasmlabel;
-         power : longint;
-         opsize : topsize;
-         hl4: pasmlabel;
-         hr : preference;
-
-         { true, if unsigned types are compared }
-         unsigned : boolean;
-         { true, if a small set is handled with the longint code }
-         is_set : boolean;
-         { is_in_dest if the result is put directly into }
-         { the resulting refernce or varregister }
-         is_in_dest : boolean;
-         { true, if for sets subtractions the extra not should generated }
-         extra_not : boolean;
-
-{$ifdef SUPPORT_MMX}
-         mmxbase : tmmxtype;
-{$endif SUPPORT_MMX}
-         pushedreg : tpushed;
-         hloc : tlocation;
-         regstopush: byte;
-
-      procedure firstjmp64bitcmp;
-
-        var
-           oldtreetype : ttreetyp;
-
-        begin
-           { the jump the sequence is a little bit hairy }
-           case p^.treetype of
-              ltn,gtn:
-                begin
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel);
-                   { cheat a little bit for the negative test }
-                   p^.swaped:=not(p^.swaped);
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel);
-                   p^.swaped:=not(p^.swaped);
-                end;
-              lten,gten:
-                begin
-                   oldtreetype:=p^.treetype;
-                   if p^.treetype=lten then
-                     p^.treetype:=ltn
-                   else
-                     p^.treetype:=gtn;
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel);
-                   { cheat for the negative test }
-                   if p^.treetype=ltn then
-                     p^.treetype:=gtn
-                   else
-                     p^.treetype:=ltn;
-                   emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel);
-                   p^.treetype:=oldtreetype;
-                end;
-              equaln:
-                emitjmp(C_NE,falselabel);
-              unequaln:
-                emitjmp(C_NE,truelabel);
-           end;
-        end;
-
-      procedure secondjmp64bitcmp;
-
-        begin
-           { the jump the sequence is a little bit hairy }
-           case p^.treetype of
-              ltn,gtn,lten,gten:
-                begin
-                   { the comparisaion of the low dword have to be }
-                   {  always unsigned!                            }
-                   emitjmp(flag_2_cond[getresflags(p,true)],truelabel);
-                   emitjmp(C_None,falselabel);
-                end;
-              equaln:
-                begin
-                   emitjmp(C_NE,falselabel);
-                   emitjmp(C_None,truelabel);
-                end;
-              unequaln:
-                begin
-                   emitjmp(C_NE,truelabel);
-                   emitjmp(C_None,falselabel);
-                end;
-           end;
-        end;
-
-
-    procedure handle_bool_as_int;
-
-      begin
-        if p^.left^.treetype=ordconstn then
-        swaptree(p);
-        if p^.left^.location.loc=LOC_JUMP then
-          begin
-            otl:=truelabel;
-            getlabel(truelabel);
-            ofl:=falselabel;
-            getlabel(falselabel);
-          end;
-
-        secondpass(p^.left);
-        { if in flags then copy first to register, because the
-          flags can be destroyed }
-        case p^.left^.location.loc of
-          LOC_FLAGS:
-            locflags2reg(p^.left^.location,opsize);
-          LOC_JUMP:
-            locjump2reg(p^.left^.location,opsize, otl, ofl);
-        end;
-        set_location(p^.location,p^.left^.location);
-        pushed:=maybe_push(p^.right^.registers32,p,false);
-        if p^.right^.location.loc=LOC_JUMP then
-          begin
-            otl:=truelabel;
-            getlabel(truelabel);
-            ofl:=falselabel;
-            getlabel(falselabel);
-          end;
-        secondpass(p^.right);
-        if pushed then
-          begin
-            restore(p,false);
-            set_location(p^.left^.location,p^.location);
-          end;
-        case p^.right^.location.loc of
-          LOC_FLAGS:
-            locflags2reg(p^.right^.location,opsize);
-          LOC_JUMP:
-            locjump2reg(p^.right^.location,opsize,otl,ofl);
-        end;
-      end;
-
-
-      begin
-      { to make it more readable, string and set (not smallset!) have their
-        own procedures }
-         case p^.left^.resulttype^.deftype of
-         stringdef : begin
-                       addstring(p);
-                       exit;
-                     end;
-            setdef : begin
-                     { normalsets are handled separate }
-                       if not(psetdef(p^.left^.resulttype)^.settype=smallset) then
-                        begin
-                          addset(p);
-                          exit;
-                        end;
-                     end;
-         end;
-
-         { defaults }
-         unsigned:=false;
-         is_in_dest:=false;
-         extra_not:=false;
-         noswap:=false;
-         opsize:=S_L;
-
-         { are we a (small)set, must be set here because the side can be
-           swapped ! (PFV) }
-         is_set:=(p^.left^.resulttype^.deftype=setdef);
-
-         { calculate the operator which is more difficult }
-         firstcomplex(p);
-
-
-         { handling boolean expressions extra: }
-         if is_boolean(p^.left^.resulttype) and
-            is_boolean(p^.right^.resulttype) then
-           begin
-             if (porddef(p^.left^.resulttype)^.typ=bool8bit) or
-               (porddef(p^.right^.resulttype)^.typ=bool8bit) then
-               opsize:=S_B
-             else
-               if (porddef(p^.left^.resulttype)^.typ=bool16bit) or
-                 (porddef(p^.right^.resulttype)^.typ=bool16bit) then
-                 opsize:=S_W
-             else
-               opsize:=S_L;
-             if (cs_full_boolean_eval in aktlocalswitches) or
-                (p^.treetype in
-                  [unequaln,ltn,lten,gtn,gten,equaln,xorn]) then
-               begin
-                 if p^.left^.treetype=ordconstn then
-                 swaptree(p);
-                 if p^.left^.location.loc=LOC_JUMP then
-                   begin
-                     otl:=truelabel;
-                     getlabel(truelabel);
-                     ofl:=falselabel;
-                     getlabel(falselabel);
-                   end;
-
-                 secondpass(p^.left);
-                 { if in flags then copy first to register, because the
-                   flags can be destroyed }
-                 case p^.left^.location.loc of
-                   LOC_FLAGS:
-                     locflags2reg(p^.left^.location,opsize);
-                   LOC_JUMP:
-                     locjump2reg(p^.left^.location,opsize, otl, ofl);
-                 end;
-                 set_location(p^.location,p^.left^.location);
-                 pushed:=maybe_push(p^.right^.registers32,p,false);
-                 if p^.right^.location.loc=LOC_JUMP then
-                   begin
-                     otl:=truelabel;
-                     getlabel(truelabel);
-                     ofl:=falselabel;
-                     getlabel(falselabel);
-                   end;
-                 secondpass(p^.right);
-                 if pushed then
-                   begin
-                     restore(p,false);
-                     set_location(p^.left^.location,p^.location);
-                   end;
-                 case p^.right^.location.loc of
-                   LOC_FLAGS:
-                     locflags2reg(p^.right^.location,opsize);
-                   LOC_JUMP:
-                     locjump2reg(p^.right^.location,opsize,otl,ofl);
-                 end;
-                 goto do_normal;
-               end;
-             case p^.treetype of
-              andn,
-               orn : begin
-                       clear_location(p^.location);
-                       p^.location.loc:=LOC_JUMP;
-                       cmpop:=false;
-                       case p^.treetype of
-                        andn : begin
-                                  otl:=truelabel;
-                                  getlabel(truelabel);
-                                  secondpass(p^.left);
-                                  maketojumpbool(p^.left);
-                                  emitlab(truelabel);
-                                  truelabel:=otl;
-                               end;
-                        orn : begin
-                                 ofl:=falselabel;
-                                 getlabel(falselabel);
-                                 secondpass(p^.left);
-                                 maketojumpbool(p^.left);
-                                 emitlab(falselabel);
-                                 falselabel:=ofl;
-                              end;
-                       else
-                         CGMessage(type_e_mismatch);
-                       end;
-                       secondpass(p^.right);
-                       maketojumpbool(p^.right);
-                     end;
-             else
-               CGMessage(type_e_mismatch);
-             end
-           end
-         else
-           begin
-              { in case of constant put it to the left }
-              if (p^.left^.treetype=ordconstn) then
-               swaptree(p);
-              secondpass(p^.left);
-              { this will be complicated as
-               a lot of code below assumes that
-               p^.location and p^.left^.location are the same }
-
-{$ifdef test_dest_loc}
-              if dest_loc_known and (dest_loc_tree=p) and
-                 ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then
-                begin
-                   set_location(p^.location,dest_loc);
-                   in_dest_loc:=true;
-                   is_in_dest:=true;
-                end
-              else
-{$endif test_dest_loc}
-                set_location(p^.location,p^.left^.location);
-
-              { are too few registers free? }
-              pushed:=maybe_push(p^.right^.registers32,p,is_64bitint(p^.left^.resulttype));
-              secondpass(p^.right);
-              if pushed then
-                begin
-                  restore(p,is_64bitint(p^.left^.resulttype));
-                  set_location(p^.left^.location,p^.location);
-                end;
-
-              if (p^.left^.resulttype^.deftype=pointerdef) or
-
-                 (p^.right^.resulttype^.deftype=pointerdef) or
-
-                 ((p^.right^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.right^.resulttype)^.is_class and
-                 (p^.left^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.left^.resulttype)^.is_class
-                 ) or
-
-                 (p^.left^.resulttype^.deftype=classrefdef) or
-
-                 (p^.left^.resulttype^.deftype=procvardef) or
-
-                 ((p^.left^.resulttype^.deftype=enumdef) and
-                  (p^.left^.resulttype^.size=4)) or
-
-                 ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=s32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=s32bit)) or
-
-                ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=u32bit)) or
-
-                { as well as small sets }
-                 is_set then
-                begin
-          do_normal:
-                   mboverflow:=false;
-                   cmpop:=false;
-{$ifndef cardinalmulfix}
-                   unsigned :=
-                     (p^.left^.resulttype^.deftype=pointerdef) or
-                     (p^.right^.resulttype^.deftype=pointerdef) or
-                     ((p^.left^.resulttype^.deftype=orddef) and
-                      (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                     ((p^.right^.resulttype^.deftype=orddef) and
-                      (porddef(p^.right^.resulttype)^.typ=u32bit));
-{$else cardinalmulfix}
-                   unsigned := not(is_signed(p^.left^.resulttype)) or
-                               not(is_signed(p^.right^.resulttype));
-{$endif cardinalmulfix}
-                   case p^.treetype of
-                      addn : begin
-                               { this is a really ugly hack!!!!!!!!!! }
-                               { this could be done later using EDI   }
-                               { as it is done for subn               }
-                               { instead of two registers!!!!         }
-                               if is_set then
-                                begin
-                                { adding elements is not commutative }
-                                  if p^.swaped and (p^.left^.treetype=setelementn) then
-                                   swaptree(p);
-                                { are we adding set elements ? }
-                                  if p^.right^.treetype=setelementn then
-                                   begin
-                                   { no range support for smallsets! }
-                                     if assigned(p^.right^.right) then
-                                      internalerror(43244);
-                                   { bts requires both elements to be registers }
-                                     if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then
-                                      begin
-                                        ungetiftemp(p^.left^.location.reference);
-                                        del_location(p^.left^.location);
-{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
-                                        hregister:=getregister32;
-                                        emit_ref_reg(A_MOV,opsize,
-                                          newreference(p^.left^.location.reference),hregister);
-                                        clear_location(p^.left^.location);
-                                        p^.left^.location.loc:=LOC_REGISTER;
-                                        p^.left^.location.register:=hregister;
-                                        set_location(p^.location,p^.left^.location);
-                                      end;
-                                     if p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE] then
-                                      begin
-                                        ungetiftemp(p^.right^.location.reference);
-                                        del_location(p^.right^.location);
-                                        hregister:=getregister32;
-                                        emit_ref_reg(A_MOV,opsize,
-                                          newreference(p^.right^.location.reference),hregister);
-                                        clear_location(p^.right^.location);
-                                        p^.right^.location.loc:=LOC_REGISTER;
-                                        p^.right^.location.register:=hregister;
-                                      end;
-                                     op:=A_BTS;
-                                     noswap:=true;
-                                   end
-                                  else
-                                   op:=A_OR;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                begin
-                                  op:=A_ADD;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                   symdifn : begin
-                               { the symetric diff is only for sets }
-                               if is_set then
-                                begin
-                                  op:=A_XOR;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                CGMessage(type_e_mismatch);
-                             end;
-                      muln : begin
-                               if is_set then
-                                begin
-                                  op:=A_AND;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                begin
-                                  if unsigned then
-                                   op:=A_MUL
-                                  else
-                                   op:=A_IMUL;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                      subn : begin
-                               if is_set then
-                                begin
-                                  op:=A_AND;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-{$IfNDef NoSetConstNot}
-                                  If (p^.right^.treetype = setconstn) then
-                                    p^.right^.location.reference.offset := not(p^.right^.location.reference.offset)
-                                  Else
-{$EndIf NoNosetConstNot}
-                                    extra_not:=true;
-                                end
-                               else
-                                begin
-                                  op:=A_SUB;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                  ltn,lten,
-                  gtn,gten,
-           equaln,unequaln : begin
-{$IfNDef NoSetInclusion}
-                               If is_set Then
-                                 Case p^.treetype of
-                                   lten,gten:
-                                     Begin
-                                      If p^.treetype = lten then
-                                        swaptree(p);
-                                      if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then
-                                        begin
-                                         ungetiftemp(p^.left^.location.reference);
-                                         del_reference(p^.left^.location.reference);
-                                         hregister:=getregister32;
-                                         emit_ref_reg(A_MOV,opsize,
-                                           newreference(p^.left^.location.reference),hregister);
-                                         clear_location(p^.left^.location);
-                                         p^.left^.location.loc:=LOC_REGISTER;
-                                         p^.left^.location.register:=hregister;
-                                         set_location(p^.location,p^.left^.location);
-                                       end
-                                      else
-                                       if p^.left^.location.loc = LOC_CREGISTER Then
-                                        {save the register var in a temp register, because
-                                          its value is going to be modified}
-                                          begin
-                                            hregister := getregister32;
-                                            emit_reg_reg(A_MOV,opsize,
-                                              p^.left^.location.register,hregister);
-                                             clear_location(p^.left^.location);
-                                             p^.left^.location.loc:=LOC_REGISTER;
-                                             p^.left^.location.register:=hregister;
-                                             set_location(p^.location,p^.left^.location);
-                                           end;
-                                     {here, p^.left^.location should be LOC_REGISTER}
-                                      If p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE] Then
-                                         emit_ref_reg(A_AND,opsize,
-                                           newreference(p^.right^.location.reference),p^.left^.location.register)
-                                      Else
-                                        emit_reg_reg(A_AND,opsize,
-                                          p^.right^.location.register,p^.left^.location.register);
-                {warning: ugly hack ahead: we need a "jne" after the cmp, so
-                 change the treetype from lten/gten to equaln}
-                                      p^.treetype := equaln
-                                     End;
-                           {no < or > support for sets}
-                                   ltn,gtn: CGMessage(type_e_mismatch);
-                                 End;
-{$EndIf NoSetInclusion}
-                               op:=A_CMP;
-                               cmpop:=true;
-                             end;
-                      xorn : op:=A_XOR;
-                       orn : op:=A_OR;
-                      andn : op:=A_AND;
-                   else
-                     CGMessage(type_e_mismatch);
-                   end;
-
-                   { filter MUL, which requires special handling }
-                   if op=A_MUL then
-                     begin
-                       popeax:=false;
-                       popedx:=false;
-                       { here you need to free the symbol first }
-                       { p^.left^.location and p^.right^.location must }
-                       { only be freed when they are really released,  }
-                       { because the optimizer NEEDS correct regalloc  }
-                       { info!!! (JM)                                  }
-                       clear_location(p^.location);
-
-                 { the p^.location.register will be filled in later (JM) }
-                       p^.location.loc:=LOC_REGISTER;
-{$IfNDef NoShlMul}
-                       if p^.right^.treetype=ordconstn then
-                        swaptree(p);
-                       If (p^.left^.treetype = ordconstn) and
-                          ispowerof2(p^.left^.value, power) and
-                          not(cs_check_overflow in aktlocalswitches) then
-                         Begin
-                           { This release will be moved after the next }
-                           { instruction by the optimizer. No need to  }
-                           { release p^.left^.location, since it's a   }
-                           { constant (JM)                             }
-                           release_loc(p^.right^.location);
-                           p^.location.register := getregister32;
-                           emitloadord2reg(p^.right^.location,u32bitdef,p^.location.register,false);
-                           emit_const_reg(A_SHL,S_L,power,p^.location.register)
-                         End
-                       Else
-                        Begin
-{$EndIf NoShlMul}
-                         regstopush := $ff;
-                         remove_non_regvars_from_loc(p^.right^.location,regstopush);
-                         remove_non_regvars_from_loc(p^.left^.location,regstopush);
-                         { now, regstopush does NOT contain EAX and/or EDX if they are }
-                         { used in either the left or the right location, excepts if   }
-                         {they are regvars. It DOES contain them if they are used in   }
-                         { another location (JM)                                       }
-                         if not(R_EAX in unused) and ((regstopush and ($80 shr byte(R_EAX))) <> 0) then
-                          begin
-                           emit_reg(A_PUSH,S_L,R_EAX);
-                           popeax:=true;
-                          end;
-                         if not(R_EDX in unused) and ((regstopush and ($80 shr byte(R_EDX))) <> 0) then
-                          begin
-                           emit_reg(A_PUSH,S_L,R_EDX);
-                           popedx:=true;
-                          end;
-                         { p^.left^.location can be R_EAX !!! }
-{$ifndef noAllocEdi}
-                         getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                         { load the left value }
-                         emitloadord2reg(p^.left^.location,u32bitdef,R_EDI,true);
-                         release_loc(p^.left^.location);
-                         { allocate EAX }
-                         if R_EAX in unused then
-                           exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-                         { load he right value }
-                         emitloadord2reg(p^.right^.location,u32bitdef,R_EAX,true);
-                         release_loc(p^.right^.location);
-                         { allocate EAX if it isn't yet allocated (JM) }
-                         if (R_EAX in unused) then
-                           exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-{$ifndef noAllocEdi}
-                         { also allocate EDX, since it is also modified by }
-                         { a mul (JM)                                      }
-                         if R_EDX in unused then
-                           exprasmlist^.concat(new(pairegalloc,alloc(R_EDX)));
-{$endif noAllocEdi}
-                         emit_reg(A_MUL,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                         ungetregister32(R_EDI);
-                         if R_EDX in unused then
-                           exprasmlist^.concat(new(pairegalloc,dealloc(R_EDX)));
-{$endif noAllocEdi}
-                         if R_EAX in unused then
-                           exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-                         p^.location.register := getregister32;
-                         emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.register);
-                         if popedx then
-                          emit_reg(A_POP,S_L,R_EDX);
-                         if popeax then
-                          emit_reg(A_POP,S_L,R_EAX);
-{$IfNDef NoShlMul}
-                        End;
-{$endif NoShlMul}
-                       SetResultLocation(false,true,p);
-                       exit;
-                     end;
-
-                   { Convert flags to register first }
-                   if (p^.left^.location.loc=LOC_FLAGS) then
-                    locflags2reg(p^.left^.location,opsize);
-                   if (p^.right^.location.loc=LOC_FLAGS) then
-                    locflags2reg(p^.right^.location,opsize);
-
-                   { left and right no register?  }
-                   { then one must be demanded    }
-                   if (p^.left^.location.loc<>LOC_REGISTER) and
-                      (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        { register variable ? }
-                        if (p^.left^.location.loc=LOC_CREGISTER) then
-                          begin
-                             { it is OK if this is the destination }
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-                             else
-                             if cmpop then
-                               begin
-                                  { do not disturb the register }
-                                  hregister:=p^.location.register;
-                               end
-                             else
-                               begin
-                                  case opsize of
-                                     S_L : hregister:=getregister32;
-                                     S_B : hregister:=reg32toreg8(getregister32);
-                                  end;
-                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-                          end
-                        else
-                          begin
-                             ungetiftemp(p^.left^.location.reference);
-                             del_reference(p^.left^.location.reference);
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_ref_reg(A_MOV,opsize,
-                                    newreference(p^.left^.location.reference),hregister);
-                               end
-                             else
-                               begin
-                                  { first give free, then demand new register }
-                                  case opsize of
-                                     S_L : hregister:=getregister32;
-                                     S_W : hregister:=reg32toreg16(getregister32);
-                                     S_B : hregister:=reg32toreg8(getregister32);
-                                  end;
-                                  emit_ref_reg(A_MOV,opsize,
-                                    newreference(p^.left^.location.reference),hregister);
-                               end;
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end
-                   else
-                     { if on the right the register then swap }
-                     if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then
-                       begin
-                          swap_location(p^.location,p^.right^.location);
-
-                          { newly swapped also set swapped flag }
-                          p^.swaped:=not(p^.swaped);
-                       end;
-                   { at this point, p^.location.loc should be LOC_REGISTER }
-                   { and p^.location.register should be a valid register   }
-                   { containing the left result                     }
-
-                    if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if p^.right^.location.loc=LOC_CREGISTER then
-                               begin
-                                  if extra_not then
-                                    emit_reg(A_NOT,opsize,p^.location.register);
-{$ifndef noAllocEdi}
-                                  getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                  emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI);
-                                  emit_reg_reg(op,opsize,p^.location.register,R_EDI);
-                                  emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register);
-{$ifndef noAllocEdi}
-                                  ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                               end
-                             else
-                               begin
-                                  if extra_not then
-                                    emit_reg(A_NOT,opsize,p^.location.register);
-
-{$ifndef noAllocEdi}
-                                  getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                  emit_ref_reg(A_MOV,opsize,
-                                    newreference(p^.right^.location.reference),R_EDI);
-                                  emit_reg_reg(op,opsize,p^.location.register,R_EDI);
-                                  emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register);
-{$ifndef noAllocEdi}
-                                  ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                                  ungetiftemp(p^.right^.location.reference);
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end
-                        else
-                          begin
-                             if (p^.right^.treetype=ordconstn) and
-                                (op=A_CMP) and
-                                (p^.right^.value=0) then
-                               begin
-                                  emit_reg_reg(A_TEST,opsize,p^.location.register,
-                                    p^.location.register);
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_ADD) and
-                                (p^.right^.value=1) and
-                                not(cs_check_overflow in aktlocalswitches) then
-                               begin
-                                  emit_reg(A_INC,opsize,
-                                    p^.location.register);
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_SUB) and
-                                (p^.right^.value=1) and
-                                not(cs_check_overflow in aktlocalswitches) then
-                               begin
-                                  emit_reg(A_DEC,opsize,
-                                    p^.location.register);
-                               end
-                             else if (p^.right^.treetype=ordconstn) and
-                                (op=A_IMUL) and
-                                (ispowerof2(p^.right^.value,power)) and
-                                not(cs_check_overflow in aktlocalswitches) then
-                               begin
-                                  emit_const_reg(A_SHL,opsize,power,
-                                    p^.location.register);
-                               end
-                             else
-                               begin
-                                  if (p^.right^.location.loc=LOC_CREGISTER) then
-                                    begin
-                                       if extra_not then
-                                         begin
-{$ifndef noAllocEdi}
-                                            getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                            emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI);
-                                            emit_reg(A_NOT,S_L,R_EDI);
-                                            emit_reg_reg(A_AND,S_L,R_EDI,
-                                              p^.location.register);
-{$ifndef noAllocEdi}
-                                            ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                                         end
-                                       else
-                                         begin
-                                            emit_reg_reg(op,opsize,p^.right^.location.register,
-                                              p^.location.register);
-                                         end;
-                                    end
-                                  else
-                                    begin
-                                       if extra_not then
-                                         begin
-{$ifndef noAllocEdi}
-                                            getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                            emit_ref_reg(A_MOV,S_L,newreference(
-                                              p^.right^.location.reference),R_EDI);
-                                            emit_reg(A_NOT,S_L,R_EDI);
-                                            emit_reg_reg(A_AND,S_L,R_EDI,
-                                              p^.location.register);
-{$ifndef noAllocEdi}
-                                            ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                                         end
-                                       else
-                                         begin
-                                            emit_ref_reg(op,opsize,newreference(
-                                              p^.right^.location.reference),p^.location.register);
-                                         end;
-                                       ungetiftemp(p^.right^.location.reference);
-                                       del_reference(p^.right^.location.reference);
-                                    end;
-                               end;
-                          end;
-                     end
-                   else
-                     begin
-                        { when swapped another result register }
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if extra_not then
-                               emit_reg(A_NOT,S_L,p^.location.register);
-
-                             emit_reg_reg(op,opsize,
-                               p^.location.register,p^.right^.location.register);
-                               swap_location(p^.location,p^.right^.location);
-                               { newly swapped also set swapped flag }
-                               { just to maintain ordering         }
-                               p^.swaped:=not(p^.swaped);
-                          end
-                        else
-                          begin
-                             if extra_not then
-                               emit_reg(A_NOT,S_L,p^.right^.location.register);
-                             emit_reg_reg(op,opsize,
-                               p^.right^.location.register,
-                               p^.location.register);
-                          end;
-                        case opsize of
-                           S_L : ungetregister32(p^.right^.location.register);
-                           S_B : ungetregister32(reg8toreg32(p^.right^.location.register));
-                        end;
-                     end;
-
-                   if cmpop then
-                     case opsize of
-                        S_L : ungetregister32(p^.location.register);
-                        S_B : ungetregister32(reg8toreg32(p^.location.register));
-                     end;
-
-                   { only in case of overflow operations }
-                   { produce overflow code }
-                   { we must put it here directly, because sign of operation }
-                   { is in unsigned VAR!!                                   }
-                   if mboverflow then
-                    begin
-                      if cs_check_overflow in aktlocalswitches  then
-                       begin
-                         getlabel(hl4);
-                         if unsigned then
-                          emitjmp(C_NB,hl4)
-                         else
-                          emitjmp(C_NO,hl4);
-                         emitcall('FPC_OVERFLOW');
-                         emitlab(hl4);
-                       end;
-                    end;
-                end
-              else
-
-              { Char type }
-                if ((p^.left^.resulttype^.deftype=orddef) and
-                    (porddef(p^.left^.resulttype)^.typ=uchar)) or
-              { enumeration type 16 bit }
-                   ((p^.left^.resulttype^.deftype=enumdef) and
-                    (p^.left^.resulttype^.size=1)) then
-                 begin
-                   case p^.treetype of
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                                cmpop:=true;
-                      else CGMessage(type_e_mismatch);
-                   end;
-                   unsigned:=true;
-                   { left and right no register? }
-                   { the one must be demanded    }
-                   if (p^.location.loc<>LOC_REGISTER) and
-                     (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        if p^.location.loc=LOC_CREGISTER then
-                          begin
-                             if cmpop then
-                               { do not disturb register }
-                               hregister:=p^.location.register
-                             else
-                               begin
-                                  hregister:=reg32toreg8(getregister32);
-                                  emit_reg_reg(A_MOV,S_B,p^.location.register,
-                                    hregister);
-                               end;
-                          end
-                        else
-                          begin
-                             del_reference(p^.location.reference);
-
-                             { first give free then demand new register }
-                             hregister:=reg32toreg8(getregister32);
-                             emit_ref_reg(A_MOV,S_B,newreference(p^.location.reference),
-                               hregister);
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end;
-
-                   { now p always a register }
-
-                   if (p^.right^.location.loc=LOC_REGISTER) and
-                      (p^.location.loc<>LOC_REGISTER) then
-                     begin
-                       swap_location(p^.location,p^.right^.location);
-                       { newly swapped also set swapped flag }
-                       p^.swaped:=not(p^.swaped);
-                     end;
-
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             emit_reg_reg(A_CMP,S_B,
-                                p^.right^.location.register,p^.location.register);
-                          end
-                        else
-                          begin
-                             emit_ref_reg(A_CMP,S_B,newreference(
-                                p^.right^.location.reference),p^.location.register);
-                             del_reference(p^.right^.location.reference);
-                          end;
-                     end
-                   else
-                     begin
-                        emit_reg_reg(A_CMP,S_B,p^.right^.location.register,
-                          p^.location.register);
-                        ungetregister32(reg8toreg32(p^.right^.location.register));
-                     end;
-                   ungetregister32(reg8toreg32(p^.location.register));
-                end
-              else
-              { 16 bit enumeration type }
-                if ((p^.left^.resulttype^.deftype=enumdef) and
-                    (p^.left^.resulttype^.size=2)) then
-                 begin
-                   case p^.treetype of
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                                cmpop:=true;
-                      else CGMessage(type_e_mismatch);
-                   end;
-                   unsigned:=true;
-                   { left and right no register? }
-                   { the one must be demanded    }
-                   if (p^.location.loc<>LOC_REGISTER) and
-                     (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        if p^.location.loc=LOC_CREGISTER then
-                          begin
-                             if cmpop then
-                               { do not disturb register }
-                               hregister:=p^.location.register
-                             else
-                               begin
-                                  hregister:=reg32toreg16(getregister32);
-                                  emit_reg_reg(A_MOV,S_W,p^.location.register,
-                                    hregister);
-                               end;
-                          end
-                        else
-                          begin
-                             del_reference(p^.location.reference);
-
-                             { first give free then demand new register }
-                             hregister:=reg32toreg16(getregister32);
-                             emit_ref_reg(A_MOV,S_W,newreference(p^.location.reference),
-                               hregister);
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end;
-
-                   { now p always a register }
-
-                   if (p^.right^.location.loc=LOC_REGISTER) and
-                      (p^.location.loc<>LOC_REGISTER) then
-                     begin
-                       swap_location(p^.location,p^.right^.location);
-                       { newly swapped also set swapped flag }
-                       p^.swaped:=not(p^.swaped);
-                     end;
-
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             emit_reg_reg(A_CMP,S_W,
-                                p^.right^.location.register,p^.location.register);
-                          end
-                        else
-                          begin
-                             emit_ref_reg(A_CMP,S_W,newreference(
-                                p^.right^.location.reference),p^.location.register);
-                             del_reference(p^.right^.location.reference);
-                          end;
-                     end
-                   else
-                     begin
-                        emit_reg_reg(A_CMP,S_W,p^.right^.location.register,
-                          p^.location.register);
-                        ungetregister32(reg16toreg32(p^.right^.location.register));
-                     end;
-                   ungetregister32(reg16toreg32(p^.location.register));
-                end
-              else
-              { 64 bit types }
-              if is_64bitint(p^.left^.resulttype) then
-                begin
-                   mboverflow:=false;
-                   cmpop:=false;
-                   unsigned:=((p^.left^.resulttype^.deftype=orddef) and
-                       (porddef(p^.left^.resulttype)^.typ=u64bit)) or
-                      ((p^.right^.resulttype^.deftype=orddef) and
-                       (porddef(p^.right^.resulttype)^.typ=u64bit));
-                   case p^.treetype of
-                      addn : begin
-                                begin
-                                  op:=A_ADD;
-                                  op2:=A_ADC;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                      subn : begin
-                                op:=A_SUB;
-                                op2:=A_SBB;
-                                mboverflow:=true;
-                             end;
-                      ltn,lten,
-                      gtn,gten,
-                      equaln,unequaln:
-                             begin
-                               op:=A_CMP;
-                               op2:=A_CMP;
-                               cmpop:=true;
-                             end;
-
-                      xorn:
-                        begin
-                           op:=A_XOR;
-                           op2:=A_XOR;
-                        end;
-
-                      orn:
-                        begin
-                           op:=A_OR;
-                           op2:=A_OR;
-                        end;
-
-                      andn:
-                        begin
-                           op:=A_AND;
-                           op2:=A_AND;
-                        end;
-                      muln:
-                        ;
-                   else
-                     CGMessage(type_e_mismatch);
-                   end;
-
-                   if p^.treetype=muln then
-                     begin
-                        { save p^.lcoation, because we change it now }
-                        set_location(hloc,p^.location);
-                        release_qword_loc(p^.location);
-                        release_qword_loc(p^.right^.location);
-                        p^.location.registerlow:=getexplicitregister32(R_EAX);
-                        p^.location.registerhigh:=getexplicitregister32(R_EDX);
-                        pushusedregisters(pushedreg,$ff
-                          and not($80 shr byte(p^.location.registerlow))
-                          and not($80 shr byte(p^.location.registerhigh)));
-                        if cs_check_overflow in aktlocalswitches then
-                          push_int(1)
-                        else
-                          push_int(0);
-                        { the left operand is in hloc, because the
-                          location of left is p^.location but p^.location
-                          is already destroyed
-                        }
-                        emit_pushq_loc(hloc);
-                        clear_location(hloc);
-                        emit_pushq_loc(p^.right^.location);
-                        if porddef(p^.resulttype)^.typ=u64bit then
-                          emitcall('FPC_MUL_QWORD')
-                        else
-                          emitcall('FPC_MUL_INT64');
-                        emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.registerlow);
-                        emit_reg_reg(A_MOV,S_L,R_EDX,p^.location.registerhigh);
-                        popusedregisters(pushedreg);
-                        p^.location.loc:=LOC_REGISTER;
-                     end
-                   else
-                     begin
-                        { left and right no register?  }
-                        { then one must be demanded    }
-                        if (p^.left^.location.loc<>LOC_REGISTER) and
-                           (p^.right^.location.loc<>LOC_REGISTER) then
-                          begin
-                             { register variable ? }
-                             if (p^.left^.location.loc=LOC_CREGISTER) then
-                               begin
-                                  { it is OK if this is the destination }
-                                  if is_in_dest then
-                                    begin
-                                       hregister:=p^.location.registerlow;
-                                       hregister2:=p^.location.registerhigh;
-                                       emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,
-                                         hregister);
-                                       emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,
-                                         hregister2);
-                                    end
-                                  else
-                                  if cmpop then
-                                    begin
-                                       { do not disturb the register }
-                                       hregister:=p^.location.registerlow;
-                                       hregister2:=p^.location.registerhigh;
-                                    end
-                                  else
-                                    begin
-                                       hregister:=getregister32;
-                                       hregister2:=getregister32;
-                                       emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,
-                                         hregister);
-                                       emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,
-                                         hregister2);
-                                    end
-                               end
-                             else
-                               begin
-                                  ungetiftemp(p^.left^.location.reference);
-                                  del_reference(p^.left^.location.reference);
-                                  if is_in_dest then
-                                    begin
-                                       hregister:=p^.location.registerlow;
-                                       hregister2:=p^.location.registerhigh;
-                                       emit_mov_ref_reg64(p^.left^.location.reference,hregister,hregister2);
-                                    end
-                                  else
-                                    begin
-                                       hregister:=getregister32;
-                                       hregister2:=getregister32;
-                                       emit_mov_ref_reg64(p^.left^.location.reference,hregister,hregister2);
-                                    end;
-                               end;
-                             clear_location(p^.location);
-                             p^.location.loc:=LOC_REGISTER;
-                             p^.location.registerlow:=hregister;
-                             p^.location.registerhigh:=hregister2;
-                          end
-                        else
-                          { if on the right the register then swap }
-                          if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then
-                            begin
-                               swap_location(p^.location,p^.right^.location);
-
-                               { newly swapped also set swapped flag }
-                               p^.swaped:=not(p^.swaped);
-                            end;
-                        { at this point, p^.location.loc should be LOC_REGISTER }
-                        { and p^.location.register should be a valid register   }
-                        { containing the left result                        }
-
-                        if p^.right^.location.loc<>LOC_REGISTER then
-                          begin
-                             if (p^.treetype=subn) and p^.swaped then
-                               begin
-                                  if p^.right^.location.loc=LOC_CREGISTER then
-                                    begin
-{$ifndef noAllocEdi}
-                                       getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                       emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI);
-                                       emit_reg_reg(op,opsize,p^.location.register,R_EDI);
-                                       emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register);
-{$ifndef noAllocEdi}
-                                       ungetregister32(R_EDI);
-                                       getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                       emit_reg_reg(A_MOV,opsize,p^.right^.location.registerhigh,R_EDI);
-                                       { the carry flag is still ok }
-                                       emit_reg_reg(op2,opsize,p^.location.registerhigh,R_EDI);
-                                       emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.registerhigh);
-{$ifndef noAllocEdi}
-                                       ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                                    end
-                                  else
-                                    begin
-{$ifndef noAllocEdi}
-                                       getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                       emit_ref_reg(A_MOV,opsize,
-                                         newreference(p^.right^.location.reference),R_EDI);
-                                       emit_reg_reg(op,opsize,p^.location.registerlow,R_EDI);
-                                       emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.registerlow);
-{$ifndef noAllocEdi}
-                                       ungetregister32(R_EDI);
-                                       getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                       hr:=newreference(p^.right^.location.reference);
-                                       inc(hr^.offset,4);
-                                       emit_ref_reg(A_MOV,opsize,
-                                         hr,R_EDI);
-                                       { here the carry flag is still preserved }
-                                       emit_reg_reg(op2,opsize,p^.location.registerhigh,R_EDI);
-                                       emit_reg_reg(A_MOV,opsize,R_EDI,
-                                         p^.location.registerhigh);
-{$ifndef noAllocEdi}
-                                       ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                                       ungetiftemp(p^.right^.location.reference);
-                                       del_reference(p^.right^.location.reference);
-                                    end;
-                               end
-                             else if cmpop then
-                               begin
-                                  if (p^.right^.location.loc=LOC_CREGISTER) then
-                                    begin
-                                       emit_reg_reg(A_CMP,S_L,p^.right^.location.registerhigh,
-                                          p^.location.registerhigh);
-                                       firstjmp64bitcmp;
-                                       emit_reg_reg(A_CMP,S_L,p^.right^.location.registerlow,
-                                          p^.location.registerlow);
-                                       secondjmp64bitcmp;
-                                    end
-                                  else
-                                    begin
-                                       hr:=newreference(p^.right^.location.reference);
-                                       inc(hr^.offset,4);
-
-                                       emit_ref_reg(A_CMP,S_L,
-                                         hr,p^.location.registerhigh);
-                                       firstjmp64bitcmp;
-
-                                       emit_ref_reg(A_CMP,S_L,newreference(
-                                         p^.right^.location.reference),p^.location.registerlow);
-                                       secondjmp64bitcmp;
-
-                                       emitjmp(C_None,falselabel);
-
-                                       ungetiftemp(p^.right^.location.reference);
-                                       del_reference(p^.right^.location.reference);
-                                    end;
-                               end
-                             else
-                               begin
-                                  {
-                                  if (p^.right^.treetype=ordconstn) and
-                                     (op=A_CMP) and
-                                     (p^.right^.value=0) then
-                                    begin
-                                       emit_reg_reg(A_TEST,opsize,p^.location.register,
-                                         p^.location.register);
-                                    end
-                                  else if (p^.right^.treetype=ordconstn) and
-                                     (op=A_IMUL) and
-                                     (ispowerof2(p^.right^.value,power)) then
-                                    begin
-                                       emit_const_reg(A_SHL,opsize,power,
-                                         p^.location.register);
-                                    end
-                                  else
-                                  }
-                                    begin
-                                       if (p^.right^.location.loc=LOC_CREGISTER) then
-                                         begin
-                                            emit_reg_reg(op,S_L,p^.right^.location.registerlow,
-                                               p^.location.registerlow);
-                                            emit_reg_reg(op2,S_L,p^.right^.location.registerhigh,
-                                               p^.location.registerhigh);
-                                         end
-                                       else
-                                         begin
-                                            emit_ref_reg(op,S_L,newreference(
-                                              p^.right^.location.reference),p^.location.registerlow);
-                                            hr:=newreference(p^.right^.location.reference);
-                                            inc(hr^.offset,4);
-                                            emit_ref_reg(op2,S_L,
-                                              hr,p^.location.registerhigh);
-                                            ungetiftemp(p^.right^.location.reference);
-                                            del_reference(p^.right^.location.reference);
-                                         end;
-                                    end;
-                               end;
-                          end
-                        else
-                          begin
-                             { when swapped another result register }
-                             if (p^.treetype=subn) and p^.swaped then
-                               begin
-                                 emit_reg_reg(op,S_L,
-                                    p^.location.registerlow,
-                                    p^.right^.location.registerlow);
-                                 emit_reg_reg(op2,S_L,
-                                    p^.location.registerhigh,
-                                    p^.right^.location.registerhigh);
-                                  swap_location(p^.location,p^.right^.location);
-                                  { newly swapped also set swapped flag }
-                                  { just to maintain ordering           }
-                                  p^.swaped:=not(p^.swaped);
-                               end
-                             else if cmpop then
-                               begin
-                                  emit_reg_reg(A_CMP,S_L,
-                                    p^.right^.location.registerhigh,
-                                    p^.location.registerhigh);
-                                  firstjmp64bitcmp;
-                                  emit_reg_reg(A_CMP,S_L,
-                                    p^.right^.location.registerlow,
-                                    p^.location.registerlow);
-                                  secondjmp64bitcmp;
-                               end
-                             else
-                               begin
-                                  emit_reg_reg(op,S_L,
-                                    p^.right^.location.registerlow,
-                                    p^.location.registerlow);
-                                  emit_reg_reg(op2,S_L,
-                                    p^.right^.location.registerhigh,
-                                    p^.location.registerhigh);
-                               end;
-                             ungetregister32(p^.right^.location.registerlow);
-                             ungetregister32(p^.right^.location.registerhigh);
-                          end;
-
-                        if cmpop then
-                          begin
-                             ungetregister32(p^.location.registerlow);
-                             ungetregister32(p^.location.registerhigh);
-                          end;
-
-                        { only in case of overflow operations }
-                        { produce overflow code }
-                        { we must put it here directly, because sign of operation }
-                        { is in unsigned VAR!!                              }
-                        if mboverflow then
-                         begin
-                           if cs_check_overflow in aktlocalswitches  then
-                            begin
-                              getlabel(hl4);
-                              if unsigned then
-                               emitjmp(C_NB,hl4)
-                              else
-                               emitjmp(C_NO,hl4);
-                              emitcall('FPC_OVERFLOW');
-                              emitlab(hl4);
-                            end;
-                         end;
-                        { we have LOC_JUMP as result }
-                        if cmpop then
-                          begin
-                             clear_location(p^.location);
-                             p^.location.loc:=LOC_JUMP;
-                             cmpop:=false;
-                          end;
-                     end;
-                end
-              else
-              { Floating point }
-               if (p^.left^.resulttype^.deftype=floatdef) and
-                  (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
-                 begin
-                    { real constants to the right, but only if it
-                      isn't on the FPU stack, i.e. 1.0 or 0.0! }
-                    if (p^.left^.treetype=realconstn) and
-                      (p^.left^.location.loc<>LOC_FPU) then
-                      swaptree(p);
-                    cmpop:=false;
-                    case p^.treetype of
-                       addn : op:=A_FADDP;
-                       muln : op:=A_FMULP;
-                       subn : op:=A_FSUBP;
-                       slashn : op:=A_FDIVP;
-                       ltn,lten,gtn,gten,
-                       equaln,unequaln : begin
-                                            op:=A_FCOMPP;
-                                            cmpop:=true;
-                                         end;
-                       else CGMessage(type_e_mismatch);
-                    end;
-
-                    if (p^.right^.location.loc<>LOC_FPU) then
-                      begin
-                         if p^.right^.location.loc=LOC_CFPUREGISTER then
-                           begin
-                              emit_reg( A_FLD,S_NO,
-                                correct_fpuregister(p^.right^.location.register,fpuvaroffset));
-                              inc(fpuvaroffset);
-                            end
-                         else
-                           floatload(pfloatdef(p^.right^.resulttype)^.typ,p^.right^.location.reference);
-                         if (p^.left^.location.loc<>LOC_FPU) then
-                           begin
-                              if p^.left^.location.loc=LOC_CFPUREGISTER then
-                                begin
-                                   emit_reg( A_FLD,S_NO,
-                                     correct_fpuregister(p^.left^.location.register,fpuvaroffset));
-                                   inc(fpuvaroffset);
-                                end
-                              else
-                                floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
-                           end
-                         { left was on the stack => swap }
-                         else
-                           p^.swaped:=not(p^.swaped);
-
-                         { releases the right reference }
-                         del_reference(p^.right^.location.reference);
-                      end
-                    { the nominator in st0 }
-                    else if (p^.left^.location.loc<>LOC_FPU) then
-                      begin
-                         if p^.left^.location.loc=LOC_CFPUREGISTER then
-                           begin
-                              emit_reg( A_FLD,S_NO,
-                                correct_fpuregister(p^.left^.location.register,fpuvaroffset));
-                              inc(fpuvaroffset);
-                           end
-                         else
-                           floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
-                      end
-                    { fpu operands are always in the wrong order on the stack }
-                    else
-                      p^.swaped:=not(p^.swaped);
-
-                    { releases the left reference }
-                    if (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-                      del_reference(p^.left^.location.reference);
-
-                    { if we swaped the tree nodes, then use the reverse operator }
-                    if p^.swaped then
-                      begin
-                         if (p^.treetype=slashn) then
-                           op:=A_FDIVRP
-                         else if (p^.treetype=subn) then
-                           op:=A_FSUBRP;
-                      end;
-                    { to avoid the pentium bug
-                    if (op=FDIVP) and (opt_processors=pentium) then
-                      emitcall('EMUL_FDIVP')
-                    else
-                    }
-                    { the Intel assemblers want operands }
-                    if op<>A_FCOMPP then
-                      begin
-                         emit_reg_reg(op,S_NO,R_ST,R_ST1);
-                         dec(fpuvaroffset);
-                      end
-                    else
-                      begin
-                         emit_none(op,S_NO);
-                         dec(fpuvaroffset,2);
-                      end;
-
-                    { on comparison load flags }
-                    if cmpop then
-                     begin
-                       if not(R_EAX in unused) then
-                         begin
-{$ifndef noAllocEdi}
-                           getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                           emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI);
-                         end;
-                       emit_reg(A_FNSTSW,S_NO,R_AX);
-                       emit_none(A_SAHF,S_NO);
-                       if not(R_EAX in unused) then
-                         begin
-                           emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
-{$ifndef noAllocEdi}
-                           ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                         end;
-                       if p^.swaped then
-                        begin
-                          case p^.treetype of
-                              equaln : flags:=F_E;
-                            unequaln : flags:=F_NE;
-                                 ltn : flags:=F_A;
-                                lten : flags:=F_AE;
-                                 gtn : flags:=F_B;
-                                gten : flags:=F_BE;
-                          end;
-                        end
-                       else
-                        begin
-                          case p^.treetype of
-                              equaln : flags:=F_E;
-                            unequaln : flags:=F_NE;
-                                 ltn : flags:=F_B;
-                                lten : flags:=F_BE;
-                                 gtn : flags:=F_A;
-                                gten : flags:=F_AE;
-                          end;
-                        end;
-                       clear_location(p^.location);
-                       p^.location.loc:=LOC_FLAGS;
-                       p^.location.resflags:=flags;
-                       cmpop:=false;
-                     end
-                    else
-                     begin
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_FPU;
-                     end;
-                 end
-{$ifdef SUPPORT_MMX}
-               else
-
-               { MMX Arrays }
-                if is_mmx_able_array(p^.left^.resulttype) then
-                 begin
-                   cmpop:=false;
-                   mmxbase:=mmx_type(p^.left^.resulttype);
-                   case p^.treetype of
-                      addn : begin
-                                if (cs_mmx_saturation in aktlocalswitches) then
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit:
-                                          op:=A_PADDSB;
-                                        mmxu8bit:
-                                          op:=A_PADDUSB;
-                                        mmxs16bit,mmxfixed16:
-                                          op:=A_PADDSB;
-                                        mmxu16bit:
-                                          op:=A_PADDUSW;
-                                     end;
-                                  end
-                                else
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit,mmxu8bit:
-                                          op:=A_PADDB;
-                                        mmxs16bit,mmxu16bit,mmxfixed16:
-                                          op:=A_PADDW;
-                                        mmxs32bit,mmxu32bit:
-                                          op:=A_PADDD;
-                                     end;
-                                  end;
-                             end;
-                      muln : begin
-                                case mmxbase of
-                                   mmxs16bit,mmxu16bit:
-                                     op:=A_PMULLW;
-                                   mmxfixed16:
-                                     op:=A_PMULHW;
-                                end;
-                             end;
-                      subn : begin
-                                if (cs_mmx_saturation in aktlocalswitches) then
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit:
-                                          op:=A_PSUBSB;
-                                        mmxu8bit:
-                                          op:=A_PSUBUSB;
-                                        mmxs16bit,mmxfixed16:
-                                          op:=A_PSUBSB;
-                                        mmxu16bit:
-                                          op:=A_PSUBUSW;
-                                     end;
-                                  end
-                                else
-                                  begin
-                                     case mmxbase of
-                                        mmxs8bit,mmxu8bit:
-                                          op:=A_PSUBB;
-                                        mmxs16bit,mmxu16bit,mmxfixed16:
-                                          op:=A_PSUBW;
-                                        mmxs32bit,mmxu32bit:
-                                          op:=A_PSUBD;
-                                     end;
-                                  end;
-                             end;
-                      {
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                             begin
-                                op:=A_CMP;
-                                cmpop:=true;
-                             end;
-                      }
-                      xorn:
-                        op:=A_PXOR;
-                      orn:
-                        op:=A_POR;
-                      andn:
-                        op:=A_PAND;
-                      else CGMessage(type_e_mismatch);
-                   end;
-                   { left and right no register?  }
-                   { then one must be demanded    }
-                   if (p^.left^.location.loc<>LOC_MMXREGISTER) and
-                     (p^.right^.location.loc<>LOC_MMXREGISTER) then
-                     begin
-                        { register variable ? }
-                        if (p^.left^.location.loc=LOC_CMMXREGISTER) then
-                          begin
-                             { it is OK if this is the destination }
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
-                                    hregister);
-                               end
-                             else
-                               begin
-                                  hregister:=getregistermmx;
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
-                                    hregister);
-                               end
-                          end
-                        else
-                          begin
-                             del_reference(p^.left^.location.reference);
-
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_ref_reg(A_MOVQ,S_NO,
-                                    newreference(p^.left^.location.reference),hregister);
-                               end
-                             else
-                               begin
-                                  hregister:=getregistermmx;
-                                  emit_ref_reg(A_MOVQ,S_NO,
-                                    newreference(p^.left^.location.reference),hregister);
-                               end;
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_MMXREGISTER;
-                        p^.location.register:=hregister;
-                     end
-                   else
-                     { if on the right the register then swap }
-                     if (p^.right^.location.loc=LOC_MMXREGISTER) then
-                       begin
-                          swap_location(p^.location,p^.right^.location);
-                          { newly swapped also set swapped flag }
-                          p^.swaped:=not(p^.swaped);
-                       end;
-                   { at this point, p^.location.loc should be LOC_MMXREGISTER }
-                   { and p^.location.register should be a valid register      }
-                   { containing the left result                        }
-                   if p^.right^.location.loc<>LOC_MMXREGISTER then
-                     begin
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if p^.right^.location.loc=LOC_CMMXREGISTER then
-                               begin
-                                  emit_reg_reg(A_MOVQ,S_NO,p^.right^.location.register,R_MM7);
-                                  emit_reg_reg(op,S_NO,p^.location.register,R_MM0);
-                                  emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register);
-                               end
-                             else
-                               begin
-                                  emit_ref_reg(A_MOVQ,S_NO,
-                                    newreference(p^.right^.location.reference),R_MM7);
-                                  emit_reg_reg(op,S_NO,p^.location.register,
-                                    R_MM7);
-                                  emit_reg_reg(A_MOVQ,S_NO,
-                                    R_MM7,p^.location.register);
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end
-                        else
-                          begin
-                             if (p^.right^.location.loc=LOC_CREGISTER) then
-                               begin
-                                  emit_reg_reg(op,S_NO,p^.right^.location.register,
-                                    p^.location.register);
-                               end
-                             else
-                               begin
-                                  emit_ref_reg(op,S_NO,newreference(
-                                    p^.right^.location.reference),p^.location.register);
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end;
-                     end
-                   else
-                     begin
-                        { when swapped another result register }
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             emit_reg_reg(op,S_NO,
-                               p^.location.register,p^.right^.location.register);
-                             swap_location(p^.location,p^.right^.location);
-                             { newly swapped also set swapped flag }
-                             { just to maintain ordering         }
-                             p^.swaped:=not(p^.swaped);
-                          end
-                        else
-                          begin
-                             emit_reg_reg(op,S_NO,
-                               p^.right^.location.register,
-                               p^.location.register);
-                          end;
-                        ungetregistermmx(p^.right^.location.register);
-                     end;
-                end
-{$endif SUPPORT_MMX}
-              else CGMessage(type_e_mismatch);
-           end;
-       SetResultLocation(cmpop,unsigned,p);
-    end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.8  2000/09/24 21:19:48  peter
-    * delphi compile fixes
-
-  Revision 1.7  2000/09/21 12:23:49  jonas
-    * small fix to my changes for full boolean evaluation support (moved
-      opsize determination for boolean operations back in boolean
-      processing block)
-
-  Revision 1.6  2000/09/21 11:30:49  jonas
-    + support for full boolean evaluation (b+/b-), default remains short
-      circuit boolean evaluation
-
-  Revision 1.5  2000/08/27 16:11:49  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.4  2000/08/04 22:00:50  peter
-    * merges from fixes
-
-  Revision 1.3  2000/07/27 09:25:05  jonas
-    * moved locflags2reg() procedure from cg386add to cgai386
-    + added locjump2reg() procedure to cgai386
-    * fixed internalerror(2002) when the result of a case expression has
-      LOC_JUMP
-    (all merged from fixes branch)
-
-  Revision 1.2  2000/07/13 11:32:32  michael
-  + removed logs
-
-}

compiler/old/cg386cal.pas

@@ -1,1629 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for in call nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published bymethodpointer
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386cal;
-
-{$i defines.inc}
-
-interface
-
-{ $define AnsiStrRef}
-
-    uses
-      symtable,tree;
-
-    procedure secondcallparan(var p : ptree;defcoll : pparaitem;
-                push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint);
-    procedure secondcalln(var p : ptree);
-    procedure secondprocinline(var p : ptree);
-
-
-implementation
-
-    uses
-{$ifdef delphi}
-      sysutils,
-{$else}
-      strings,
-{$endif}
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,aasm,types,
-{$ifdef GDB}
-      gdb,
-{$endif GDB}
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386,cg386ld;
-
-{*****************************************************************************
-                             SecondCallParaN
-*****************************************************************************}
-
-    procedure secondcallparan(var p : ptree;defcoll : pparaitem;
-                push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint);
-
-      procedure maybe_push_high;
-        begin
-           { open array ? }
-           { defcoll^.data can be nil for read/write }
-           if assigned(defcoll^.paratype.def) and
-              push_high_param(defcoll^.paratype.def) then
-             begin
-               if assigned(p^.hightree) then
-                begin
-                  secondpass(p^.hightree);
-                  { this is a longint anyway ! }
-                  push_value_para(p^.hightree,inlined,false,para_offset,4);
-                end
-               else
-                internalerror(432645);
-             end;
-        end;
-
-      procedure prepareout(const r : treference);
-
-        var
-           hr : treference;
-           pushed : tpushed;
-
-        begin
-           { out parameters needs to be finalized }
-           if (defcoll^.paratype.def^.needs_inittable) then
-             begin
-                reset_reference(hr);
-                hr.symbol:=defcoll^.paratype.def^.get_inittable_label;
-                emitpushreferenceaddr(hr);
-                emitpushreferenceaddr(r);
-                emitcall('FPC_FINALIZE');
-             end
-           else
-           { or at least it zeroed out }
-             begin
-                case defcoll^.paratype.def^.size of
-                   1:
-                     emit_const_ref(A_MOV,S_B,0,newreference(r));
-                   2:
-                     emit_const_ref(A_MOV,S_W,0,newreference(r));
-                   4:
-                     emit_const_ref(A_MOV,S_L,0,newreference(r));
-                   else
-                     begin
-                        pushusedregisters(pushed,$ff);
-                        emit_const(A_PUSH,S_W,0);
-                        push_int(defcoll^.paratype.def^.size);
-                        emitpushreferenceaddr(r);
-                        emitcall('FPC_FILLCHAR');
-                        popusedregisters(pushed);
-                     end
-                end;
-             end;
-        end;
-      var
-         otlabel,oflabel : pasmlabel;
-         { temporary variables: }
-         tempdeftype : tdeftype;
-         r : preference;
-
-      begin
-         { set default para_alignment to target_os.stackalignment }
-         if para_alignment=0 then
-          para_alignment:=target_os.stackalignment;
-
-         { push from left to right if specified }
-         if push_from_left_to_right and assigned(p^.right) then
-           secondcallparan(p^.right,pparaitem(defcoll^.next),push_from_left_to_right,
-             inlined,is_cdecl,para_alignment,para_offset);
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         secondpass(p^.left);
-         { filter array constructor with c styled args }
-         if is_array_constructor(p^.left^.resulttype) and p^.left^.cargs then
-           begin
-             { nothing, everything is already pushed }
-           end
-         { in codegen.handleread.. defcoll^.data is set to nil }
-         else if assigned(defcoll^.paratype.def) and
-           (defcoll^.paratype.def^.deftype=formaldef) then
-           begin
-              { allow @var }
-              inc(pushedparasize,4);
-              if (p^.left^.treetype=addrn) and
-                 (not p^.left^.procvarload) then
-                begin
-                { always a register }
-                  if inlined then
-                    begin
-                       r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                       emit_reg_ref(A_MOV,S_L,
-                         p^.left^.location.register,r);
-                    end
-                  else
-                    emit_reg(A_PUSH,S_L,p^.left^.location.register);
-                  ungetregister32(p^.left^.location.register);
-                end
-              else
-                begin
-                   if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-                     CGMessage(type_e_mismatch)
-                   else
-                     begin
-                       if inlined then
-                         begin
-{$ifndef noAllocEdi}
-                           getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                           emit_ref_reg(A_LEA,S_L,
-                             newreference(p^.left^.location.reference),R_EDI);
-                           r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                           emit_reg_ref(A_MOV,S_L,R_EDI,r);
-{$ifndef noAllocEdi}
-                           ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                         end
-                      else
-                        emitpushreferenceaddr(p^.left^.location.reference);
-                        del_reference(p^.left^.location.reference);
-                     end;
-                end;
-           end
-         { handle call by reference parameter }
-         else if (defcoll^.paratyp in [vs_var,vs_out]) then
-           begin
-              if (p^.left^.location.loc<>LOC_REFERENCE) then
-                CGMessage(cg_e_var_must_be_reference);
-              maybe_push_high;
-              inc(pushedparasize,4);
-              if inlined then
-                begin
-{$ifndef noAllocEdi}
-                   getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                   emit_ref_reg(A_LEA,S_L,
-                     newreference(p^.left^.location.reference),R_EDI);
-                   r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                   emit_reg_ref(A_MOV,S_L,R_EDI,r);
-{$ifndef noAllocEdi}
-                   ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                end
-              else
-                emitpushreferenceaddr(p^.left^.location.reference);
-              if defcoll^.paratyp=vs_out then
-                prepareout(p^.left^.location.reference);
-              del_reference(p^.left^.location.reference);
-           end
-         else
-           begin
-              tempdeftype:=p^.resulttype^.deftype;
-              if tempdeftype=filedef then
-               CGMessage(cg_e_file_must_call_by_reference);
-              { open array must always push the address, this is needed to
-                also push addr of small open arrays and with cdecl functions (PFV) }
-              if (
-                  assigned(defcoll^.paratype.def) and
-                  (is_open_array(defcoll^.paratype.def) or
-                   is_array_of_const(defcoll^.paratype.def))
-                 ) or
-                 (
-                  push_addr_param(p^.resulttype) and
-                  not is_cdecl
-                 ) then
-                begin
-                   maybe_push_high;
-                   inc(pushedparasize,4);
-                   if inlined then
-                     begin
-{$ifndef noAllocEdi}
-                        getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                        emit_ref_reg(A_LEA,S_L,
-                          newreference(p^.left^.location.reference),R_EDI);
-                        r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
-                        emit_reg_ref(A_MOV,S_L,R_EDI,r);
-{$ifndef noAllocEdi}
-                        ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                     end
-                   else
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                   del_reference(p^.left^.location.reference);
-                end
-              else
-                begin
-                   push_value_para(p^.left,inlined,is_cdecl,
-                     para_offset,para_alignment);
-                end;
-           end;
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-         { push from right to left }
-         if not push_from_left_to_right and assigned(p^.right) then
-           secondcallparan(p^.right,pparaitem(defcoll^.next),push_from_left_to_right,
-             inlined,is_cdecl,para_alignment,para_offset);
-      end;
-
-
-{*****************************************************************************
-                             SecondCallN
-*****************************************************************************}
-
-    procedure secondcalln(var p : ptree);
-      var
-         unusedregisters : tregisterset;
-         usablecount : byte;
-         pushed : tpushed;
-         hr,funcretref : treference;
-         hregister,hregister2 : tregister;
-         oldpushedparasize : longint;
-         { true if ESI must be loaded again after the subroutine }
-         loadesi : boolean;
-         { true if a virtual method must be called directly }
-         no_virtual_call : boolean;
-         { true if we produce a con- or destrutor in a call }
-         is_con_or_destructor : boolean;
-         { true if a constructor is called again }
-         extended_new : boolean;
-         { adress returned from an I/O-error }
-         iolabel : pasmlabel;
-         { lexlevel count }
-         i : longint;
-         { help reference pointer }
-         r : preference;
-         hp,
-         pp,params : ptree;
-         inlined : boolean;
-         inlinecode : ptree;
-         para_alignment,
-         para_offset : longint;
-         { instruction for alignement correction }
-{        corr : paicpu;}
-         { we must pop this size also after !! }
-{        must_pop : boolean; }
-         pop_size : longint;
-         pop_allowed : boolean;
-         pop_esp : boolean;
-         push_size : longint;
-
-
-      label
-         dont_call;
-
-      begin
-         reset_reference(p^.location.reference);
-         extended_new:=false;
-         iolabel:=nil;
-         inlinecode:=nil;
-         inlined:=false;
-         loadesi:=true;
-         no_virtual_call:=false;
-         unusedregisters:=unused;
-         usablecount:=usablereg32;
-
-         if (pocall_cdecl in p^.procdefinition^.proccalloptions) or
-            (pocall_stdcall in p^.procdefinition^.proccalloptions) then
-          para_alignment:=4
-         else
-          para_alignment:=target_os.stackalignment;
-
-         if not assigned(p^.procdefinition) then
-          exit;
-
-         { Deciding whether we may still need the parameters happens next (JM) }
-         params:=p^.left;
-
-         if (pocall_inline in p^.procdefinition^.proccalloptions) then
-           begin
-              { make a copy for the next time the procedure is inlined (JM) }
-              p^.left:=getcopy(p^.left);
-              inlined:=true;
-              inlinecode:=p^.right;
-              { set it to the same lexical level as the local symtable, becuase
-                the para's are stored there }
-              pprocdef(p^.procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel;
-              if assigned(params) then
-                inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size);
-              pprocdef(p^.procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset;
-{$ifdef extdebug}
-             Comment(V_debug,
-               'inlined parasymtable is at offset '
-               +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup));
-             exprasmlist^.concat(new(pai_asm_comment,init(
-               strpnew('inlined parasymtable is at offset '
-               +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup)))));
-{$endif extdebug}
-              { copy for the next time the procedure is inlined (JM) }
-              p^.right:=getcopy(p^.right);
-              { disable further inlining of the same proc
-                in the args }
-              exclude(p^.procdefinition^.proccalloptions,pocall_inline);
-           end
-         else
-           { parameters not necessary anymore (JM) }
-           p^.left := nil;
-         { only if no proc var }
-         if inlined or
-            not(assigned(p^.right)) then
-           is_con_or_destructor:=(p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]);
-         { proc variables destroy all registers }
-         if (inlined or
-            (p^.right=nil)) and
-            { virtual methods too }
-            not(po_virtualmethod in p^.procdefinition^.procoptions) then
-           begin
-              if (cs_check_io in aktlocalswitches) and
-                 (po_iocheck in p^.procdefinition^.procoptions) and
-                 not(po_iocheck in aktprocsym^.definition^.procoptions) then
-                begin
-                   getaddrlabel(iolabel);
-                   emitlab(iolabel);
-                end
-              else
-                iolabel:=nil;
-
-              { save all used registers }
-              pushusedregisters(pushed,pprocdef(p^.procdefinition)^.usedregisters);
-
-              { give used registers through }
-              usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters;
-           end
-         else
-           begin
-              pushusedregisters(pushed,$ff);
-              usedinproc:=$ff;
-              { no IO check for methods and procedure variables }
-              iolabel:=nil;
-           end;
-
-         { generate the code for the parameter and push them }
-         oldpushedparasize:=pushedparasize;
-         pushedparasize:=0;
-         pop_size:=0;
-         { no inc esp for inlined procedure
-           and for objects constructors PM }
-         if (inlined or
-            (p^.right=nil)) and
-            (p^.procdefinition^.proctypeoption=potype_constructor) and
-            { quick'n'dirty check if it is a class or an object }
-            (p^.resulttype^.deftype=orddef) then
-           pop_allowed:=false
-         else
-           pop_allowed:=true;
-         if pop_allowed then
-          begin
-          { Old pushedsize aligned on 4 ? }
-            i:=oldpushedparasize and 3;
-            if i>0 then
-             inc(pop_size,4-i);
-          { This parasize aligned on 4 ? }
-            i:=p^.procdefinition^.para_size(para_alignment) and 3;
-            if i>0 then
-             inc(pop_size,4-i);
-          { insert the opcode and update pushedparasize }
-          { never push 4 or more !! }
-            pop_size:=pop_size mod 4;
-            if pop_size>0 then
-             begin
-               inc(pushedparasize,pop_size);
-               emit_const_reg(A_SUB,S_L,pop_size,R_ESP);
-{$ifdef GDB}
-               if (cs_debuginfo in aktmoduleswitches) and
-                  (exprasmlist^.first=exprasmlist^.last) then
-                 exprasmlist^.concat(new(pai_force_line,init));
-{$endif GDB}
-             end;
-          end;
-         if pop_allowed and (cs_align in aktglobalswitches) then
-           begin
-              pop_esp:=true;
-              push_size:=p^.procdefinition^.para_size(para_alignment);
-              { !!!! here we have to take care of return type, self
-                and nested procedures
-              }
-              inc(push_size,12);
-              emit_reg_reg(A_MOV,S_L,R_ESP,R_EDI);
-              if (push_size mod 8)=0 then
-                emit_const_reg(A_AND,S_L,$fffffff8,R_ESP)
-              else
-                begin
-                   emit_const_reg(A_SUB,S_L,push_size,R_ESP);
-                   emit_const_reg(A_AND,S_L,$fffffff8,R_ESP);
-                   emit_const_reg(A_SUB,S_L,push_size,R_ESP);
-                end;
-              emit_reg(A_PUSH,S_L,R_EDI);
-           end
-         else
-           pop_esp:=false;
-         if (p^.resulttype<>pdef(voiddef)) and
-            ret_in_param(p^.resulttype) then
-           begin
-              funcretref.symbol:=nil;
-{$ifdef test_dest_loc}
-              if dest_loc_known and (dest_loc_tree=p) and
-                 (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
-                begin
-                   funcretref:=dest_loc.reference;
-                   if assigned(dest_loc.reference.symbol) then
-                     funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
-                   in_dest_loc:=true;
-                end
-              else
-{$endif test_dest_loc}
-                if inlined then
-                  begin
-                     reset_reference(funcretref);
-                     funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.rettype.def^.size);
-                     funcretref.base:=procinfo^.framepointer;
-                  end
-                else
-                  gettempofsizereference(p^.procdefinition^.rettype.def^.size,funcretref);
-           end;
-         if assigned(params) then
-           begin
-              { be found elsewhere }
-              if inlined then
-                para_offset:=pprocdef(p^.procdefinition)^.parast^.address_fixup+
-                  pprocdef(p^.procdefinition)^.parast^.datasize
-              else
-                para_offset:=0;
-              if not(inlined) and
-                 assigned(p^.right) then
-                secondcallparan(params,pparaitem(pabstractprocdef(p^.right^.resulttype)^.para^.first),
-                  (pocall_leftright in p^.procdefinition^.proccalloptions),inlined,
-                  (pocall_cdecl in p^.procdefinition^.proccalloptions),
-                  para_alignment,para_offset)
-              else
-                secondcallparan(params,pparaitem(p^.procdefinition^.para^.first),
-                  (pocall_leftright in p^.procdefinition^.proccalloptions),inlined,
-                  (pocall_cdecl in p^.procdefinition^.proccalloptions),
-                  para_alignment,para_offset);
-           end;
-         if inlined then
-           inlinecode^.retoffset:=gettempofsizepersistant(4);
-         if ret_in_param(p^.resulttype) then
-           begin
-              { This must not be counted for C code
-                complex return address is removed from stack
-                by function itself !   }
-{$ifdef OLD_C_STACK}
-              inc(pushedparasize,4); { lets try without it PM }
-{$endif not OLD_C_STACK}
-              if inlined then
-                begin
-{$ifndef noAllocEdi}
-                   getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                   emit_ref_reg(A_LEA,S_L,
-                     newreference(funcretref),R_EDI);
-                   r:=new_reference(procinfo^.framepointer,inlinecode^.retoffset);
-                   emit_reg_ref(A_MOV,S_L,R_EDI,r);
-{$ifndef noAllocEdi}
-                   ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                end
-              else
-                emitpushreferenceaddr(funcretref);
-           end;
-         { procedure variable ? }
-         if inlined or
-           (p^.right=nil) then
-           begin
-              { overloaded operator have no symtable }
-              { push self }
-              if assigned(p^.symtable) and
-                (p^.symtable^.symtabletype=withsymtable) then
-                begin
-                   { dirty trick to avoid the secondcall below }
-                   p^.methodpointer:=genzeronode(callparan);
-                   p^.methodpointer^.location.loc:=LOC_REGISTER;
-{$ifndef noAllocEDI}
-                   getexplicitregister32(R_ESI);
-{$endif noAllocEDI}
-                   p^.methodpointer^.location.register:=R_ESI;
-                   { ARGHHH this is wrong !!!
-                     if we can init from base class for a child
-                     class that the wrong VMT will be
-                     transfered to constructor !! }
-                   p^.methodpointer^.resulttype:=
-                     ptree(pwithsymtable(p^.symtable)^.withnode)^.left^.resulttype;
-                   { change dispose type !! }
-                   p^.disposetyp:=dt_mbleft_and_method;
-                   { make a reference }
-                   new(r);
-                   reset_reference(r^);
-                   { if assigned(ptree(pwithsymtable(p^.symtable)^.withnode)^.pref) then
-                     begin
-                        r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.pref^;
-                     end
-                   else
-                     begin
-                        r^.offset:=p^.symtable^.datasize;
-                        r^.base:=procinfo^.framepointer;
-                     end; }
-                   r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^;
-                   if ((not ptree(pwithsymtable(p^.symtable)^.withnode)^.islocal) and
-                       (not pwithsymtable(p^.symtable)^.direct_with)) or
-                      pobjectdef(p^.methodpointer^.resulttype)^.is_class then
-                     emit_ref_reg(A_MOV,S_L,r,R_ESI)
-                   else
-                     emit_ref_reg(A_LEA,S_L,r,R_ESI);
-                end;
-
-              { push self }
-              if assigned(p^.symtable) and
-                ((p^.symtable^.symtabletype=objectsymtable) or
-                (p^.symtable^.symtabletype=withsymtable)) then
-                begin
-                   if assigned(p^.methodpointer) then
-                     begin
-                        {
-                        if p^.methodpointer^.resulttype=classrefdef then
-                          begin
-                              two possibilities:
-                               1. constructor
-                               2. class method
-
-                          end
-                        else }
-                          begin
-                             case p^.methodpointer^.treetype of
-                               typen:
-                                 begin
-                                    { direct call to inherited method }
-                                    if (po_abstractmethod in p^.procdefinition^.procoptions) then
-                                      begin
-                                         CGMessage(cg_e_cant_call_abstract_method);
-                                         goto dont_call;
-                                      end;
-                                    { generate no virtual call }
-                                    no_virtual_call:=true;
-
-                                    if (sp_static in p^.symtableprocentry^.symoptions) then
-                                      begin
-                                         { well lets put the VMT address directly into ESI }
-                                         { it is kind of dirty but that is the simplest    }
-                                         { way to accept virtual static functions (PM)     }
-                                         loadesi:=true;
-                                         { if no VMT just use $0 bug0214 PM }
-{$ifndef noAllocEDI}
-                                         getexplicitregister32(R_ESI);
-{$endif noAllocEDI}
-                                         if not(oo_has_vmt in pobjectdef(p^.methodpointer^.resulttype)^.objectoptions) then
-                                           emit_const_reg(A_MOV,S_L,0,R_ESI)
-                                         else
-                                           begin
-                                             emit_sym_ofs_reg(A_MOV,S_L,
-                                               newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname),
-                                               0,R_ESI);
-                                           end;
-                                         { emit_reg(A_PUSH,S_L,R_ESI);
-                                           this is done below !! }
-                                      end
-                                    else
-                                      { this is a member call, so ESI isn't modfied }
-                                      loadesi:=false;
-
-                                    { a class destructor needs a flag }
-                                    if pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                       {assigned(aktprocsym) and
-                                       (aktprocsym^.definition^.proctypeoption=potype_destructor)}
-                                       (p^.procdefinition^.proctypeoption=potype_destructor) then
-                                      begin
-                                        push_int(0);
-                                        emit_reg(A_PUSH,S_L,R_ESI);
-                                      end;
-
-                                    if not(is_con_or_destructor and
-                                           pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                           {assigned(aktprocsym) and
-                                          (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])}
-                                           (p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor])
-                                          ) then
-                                      emit_reg(A_PUSH,S_L,R_ESI);
-                                    { if an inherited con- or destructor should be  }
-                                    { called in a con- or destructor then a warning }
-                                    { will be made                                  }
-                                    { con- and destructors need a pointer to the vmt }
-                                    if is_con_or_destructor and
-                                    not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and
-                                    assigned(aktprocsym) then
-                                      begin
-                                         if not(aktprocsym^.definition^.proctypeoption in
-                                                [potype_constructor,potype_destructor]) then
-                                          CGMessage(cg_w_member_cd_call_from_method);
-                                      end;
-                                    { class destructors get there flag above }
-                                    { constructor flags ?                    }
-                                    if is_con_or_destructor and
-                                        not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                        assigned(aktprocsym) and
-                                        (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
-                                      begin
-                                         { a constructor needs also a flag }
-                                         if pobjectdef(p^.methodpointer^.resulttype)^.is_class then
-                                           push_int(0);
-                                         push_int(0);
-                                      end;
-                                 end;
-                               hnewn:
-                                 begin
-                                    { extended syntax of new }
-                                    { ESI must be zero }
-{$ifndef noAllocEDI}
-                                    getexplicitregister32(R_ESI);
-{$endif noAllocEDI}
-                                    emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI);
-                                    emit_reg(A_PUSH,S_L,R_ESI);
-                                    { insert the vmt }
-                                    emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname));
-                                    extended_new:=true;
-                                 end;
-                               hdisposen:
-                                 begin
-                                    secondpass(p^.methodpointer);
-
-                                    { destructor with extended syntax called from dispose }
-                                    { hdisposen always deliver LOC_REFERENCE          }
-{$ifndef noAllocEDI}
-                                    getexplicitregister32(R_ESI);
-{$endif noAllocEDI}
-                                    emit_ref_reg(A_LEA,S_L,
-                                      newreference(p^.methodpointer^.location.reference),R_ESI);
-                                    del_reference(p^.methodpointer^.location.reference);
-                                    emit_reg(A_PUSH,S_L,R_ESI);
-                                    emit_sym(A_PUSH,S_L,
-                                      newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname));
-                                 end;
-                               else
-                                 begin
-                                    { call to an instance member }
-                                    if (p^.symtable^.symtabletype<>withsymtable) then
-                                      begin
-                                         secondpass(p^.methodpointer);
-{$ifndef noAllocEDI}
-                                         getexplicitregister32(R_ESI);
-{$endif noAllocEDI}
-                                         case p^.methodpointer^.location.loc of
-                                            LOC_CREGISTER,
-                                            LOC_REGISTER:
-                                              begin
-                                                 emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI);
-                                                 ungetregister32(p^.methodpointer^.location.register);
-                                              end;
-                                            else
-                                              begin
-                                                 if (p^.methodpointer^.resulttype^.deftype=classrefdef) or
-                                                    ((p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                                   pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                                   emit_ref_reg(A_MOV,S_L,
-                                                     newreference(p^.methodpointer^.location.reference),R_ESI)
-                                                 else
-                                                   emit_ref_reg(A_LEA,S_L,
-                                                     newreference(p^.methodpointer^.location.reference),R_ESI);
-                                                 del_reference(p^.methodpointer^.location.reference);
-                                              end;
-                                         end;
-                                      end;
-                                    { when calling a class method, we have to load ESI with the VMT !
-                                      But, not for a class method via self }
-                                    if not(po_containsself in p^.procdefinition^.procoptions) then
-                                      begin
-                                        if (po_classmethod in p^.procdefinition^.procoptions) and
-                                           not(p^.methodpointer^.resulttype^.deftype=classrefdef) then
-                                          begin
-                                             { class method needs current VMT }
-                                             getexplicitregister32(R_ESI);
-                                             new(r);
-                                             reset_reference(r^);
-                                             r^.base:=R_ESI;
-                                             r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-                                             emit_ref_reg(A_MOV,S_L,r,R_ESI);
-                                          end;
-
-                                        { direct call to destructor: remove data }
-                                        if (p^.procdefinition^.proctypeoption=potype_destructor) and
-                                           (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                          emit_const(A_PUSH,S_L,1);
-
-                                        { direct call to class constructor, don't allocate memory }
-                                        if (p^.procdefinition^.proctypeoption=potype_constructor) and
-                                           (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                          begin
-                                             emit_const(A_PUSH,S_L,0);
-                                             emit_const(A_PUSH,S_L,0);
-                                          end
-                                        else
-                                          begin
-                                             { constructor call via classreference => allocate memory }
-                                             if (p^.procdefinition^.proctypeoption=potype_constructor) and
-                                                (p^.methodpointer^.resulttype^.deftype=classrefdef) and
-                                                (pobjectdef(pclassrefdef(p^.methodpointer^.resulttype)^.
-                                                   pointertype.def)^.is_class) then
-                                                emit_const(A_PUSH,S_L,1);
-                                             emit_reg(A_PUSH,S_L,R_ESI);
-                                          end;
-                                      end;
-
-                                    if is_con_or_destructor then
-                                      begin
-                                         { classes don't get a VMT pointer pushed }
-                                         if (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                           not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                           begin
-                                              if (p^.procdefinition^.proctypeoption=potype_constructor) then
-                                                begin
-                                                   { it's no bad idea, to insert the VMT }
-                                                   emit_sym(A_PUSH,S_L,newasmsymbol(
-                                                     pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname));
-                                                end
-                                              { destructors haven't to dispose the instance, if this is }
-                                              { a direct call                                           }
-                                              else
-                                                push_int(0);
-                                           end;
-                                      end;
-                                 end;
-                             end;
-                          end;
-                     end
-                   else
-                     begin
-                        if (po_classmethod in p^.procdefinition^.procoptions) and
-                          not(
-                            assigned(aktprocsym) and
-                            (po_classmethod in aktprocsym^.definition^.procoptions)
-                          ) then
-                          begin
-                             { class method needs current VMT }
-                             getexplicitregister32(R_ESI);
-                             new(r);
-                             reset_reference(r^);
-                             r^.base:=R_ESI;
-                             r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-                             emit_ref_reg(A_MOV,S_L,r,R_ESI);
-                          end
-                        else
-                          begin
-                             { member call, ESI isn't modified }
-                             loadesi:=false;
-                          end;
-                        { direct call to destructor: don't remove data! }
-                        if procinfo^._class^.is_class then
-                          begin
-                             if (p^.procdefinition^.proctypeoption=potype_destructor) then
-                               begin
-                                  emit_const(A_PUSH,S_L,0);
-                                  emit_reg(A_PUSH,S_L,R_ESI);
-                               end
-                             else if (p^.procdefinition^.proctypeoption=potype_constructor) then
-                               begin
-                                  emit_const(A_PUSH,S_L,0);
-                                  emit_const(A_PUSH,S_L,0);
-                               end
-                             else
-                               emit_reg(A_PUSH,S_L,R_ESI);
-                          end
-                        else
-                          begin
-                             emit_reg(A_PUSH,S_L,R_ESI);
-                             if is_con_or_destructor then
-                               begin
-                                  if (p^.procdefinition^.proctypeoption=potype_constructor) then
-                                    begin
-                                       { it's no bad idea, to insert the VMT }
-                                       emit_sym(A_PUSH,S_L,newasmsymbol(
-                                         procinfo^._class^.vmt_mangledname));
-                                    end
-                                  { destructors haven't to dispose the instance, if this is }
-                                  { a direct call                                           }
-                                  else
-                                    push_int(0);
-                               end;
-                          end;
-                     end;
-                end;
-
-              { push base pointer ?}
-              if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and
-                ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then
-                begin
-                   { if we call a nested function in a method, we must      }
-                   { push also SELF!                                    }
-                   { THAT'S NOT TRUE, we have to load ESI via frame pointer }
-                   { access                                              }
-                   {
-                     begin
-                        loadesi:=false;
-                        emit_reg(A_PUSH,S_L,R_ESI);
-                     end;
-                   }
-                   if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
-                     begin
-                        new(r);
-                        reset_reference(r^);
-                        r^.offset:=procinfo^.framepointer_offset;
-                        r^.base:=procinfo^.framepointer;
-                        emit_ref(A_PUSH,S_L,r)
-                     end
-                     { this is only true if the difference is one !!
-                       but it cannot be more !! }
-                   else if (lexlevel=pprocdef(p^.procdefinition)^.parast^.symtablelevel-1) then
-                     begin
-                        emit_reg(A_PUSH,S_L,procinfo^.framepointer)
-                     end
-                   else if (lexlevel>pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
-                     begin
-                        hregister:=getregister32;
-                        new(r);
-                        reset_reference(r^);
-                        r^.offset:=procinfo^.framepointer_offset;
-                        r^.base:=procinfo^.framepointer;
-                        emit_ref_reg(A_MOV,S_L,r,hregister);
-                        for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do
-                          begin
-                             new(r);
-                             reset_reference(r^);
-                             {we should get the correct frame_pointer_offset at each level
-                             how can we do this !!! }
-                             r^.offset:=procinfo^.framepointer_offset;
-                             r^.base:=hregister;
-                             emit_ref_reg(A_MOV,S_L,r,hregister);
-                          end;
-                        emit_reg(A_PUSH,S_L,hregister);
-                        ungetregister32(hregister);
-                     end
-                   else
-                     internalerror(25000);
-                end;
-
-              if (po_virtualmethod in p^.procdefinition^.procoptions) and
-                 not(no_virtual_call) then
-                begin
-                   { static functions contain the vmt_address in ESI }
-                   { also class methods                       }
-                   { Here it is quite tricky because it also depends }
-                   { on the methodpointer                        PM }
-                   getexplicitregister32(R_ESI);
-                   if assigned(aktprocsym) then
-                     begin
-                       if (((sp_static in aktprocsym^.symoptions) or
-                        (po_classmethod in aktprocsym^.definition^.procoptions)) and
-                        ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen)))
-                        or
-                        (po_staticmethod in p^.procdefinition^.procoptions) or
-                        ((p^.procdefinition^.proctypeoption=potype_constructor) and
-                        { esi contains the vmt if we call a constructor via a class ref }
-                         assigned(p^.methodpointer) and
-                         (p^.methodpointer^.resulttype^.deftype=classrefdef)
-                        ) or
-                        { ESI is loaded earlier }
-                        (po_classmethod in p^.procdefinition^.procoptions) then
-                         begin
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_ESI;
-                         end
-                       else
-                         begin
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_ESI;
-                            { this is one point where we need vmt_offset (PM) }
-                            r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-{$ifndef noAllocEdi}
-                            getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                            emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_EDI;
-                         end;
-                     end
-                   else
-                     { aktprocsym should be assigned, also in main program }
-                     internalerror(12345);
-                   {
-                     begin
-                       new(r);
-                       reset_reference(r^);
-                       r^.base:=R_ESI;
-                       emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                       new(r);
-                       reset_reference(r^);
-                       r^.base:=R_EDI;
-                     end;
-                   }
-                   if pprocdef(p^.procdefinition)^.extnumber=-1 then
-                     internalerror(44584);
-                   r^.offset:=pprocdef(p^.procdefinition)^._class^.vmtmethodoffset(pprocdef(p^.procdefinition)^.extnumber);
-                   if (cs_check_object_ext in aktlocalswitches) then
-                     begin
-                        emit_sym(A_PUSH,S_L,
-                          newasmsymbol(pprocdef(p^.procdefinition)^._class^.vmt_mangledname));
-                        emit_reg(A_PUSH,S_L,r^.base);
-                        emitcall('FPC_CHECK_OBJECT_EXT');
-                     end
-                   else if (cs_check_range in aktlocalswitches) then
-                     begin
-                        emit_reg(A_PUSH,S_L,r^.base);
-                        emitcall('FPC_CHECK_OBJECT');
-                     end;
-                   emit_ref(A_CALL,S_NO,r);
-{$ifndef noAllocEdi}
-                   ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                end
-              else if not inlined then
-                begin
-                  { We can call interrupts from within the smae code
-                    by just pushing the flags and CS PM }
-                  if (po_interrupt in p^.procdefinition^.procoptions) then
-                    begin
-                        emit_none(A_PUSHF,S_L);
-                        emit_reg(A_PUSH,S_L,R_CS);
-                    end;
-                  emitcall(pprocdef(p^.procdefinition)^.mangledname);
-                end
-              else { inlined proc }
-                { inlined code is in inlinecode }
-                begin
-                   { set poinline again }
-                   include(p^.procdefinition^.proccalloptions,pocall_inline);
-                   { process the inlinecode }
-                   secondpass(inlinecode);
-                   { free the args }
-                   if pprocdef(p^.procdefinition)^.parast^.datasize>0 then
-                     ungetpersistanttemp(pprocdef(p^.procdefinition)^.parast^.address_fixup);
-                end;
-           end
-         else
-           { now procedure variable case }
-           begin
-              secondpass(p^.right);
-              if (po_interrupt in p^.procdefinition^.procoptions) then
-                begin
-                    emit_none(A_PUSHF,S_L);
-                    emit_reg(A_PUSH,S_L,R_CS);
-                end;
-              { procedure of object? }
-              if (po_methodpointer in p^.procdefinition^.procoptions) then
-                begin
-                   { method pointer can't be in a register }
-                   hregister:=R_NO;
-
-                   { do some hacking if we call a method pointer }
-                   { which is a class member                 }
-                   { else ESI is overwritten !             }
-                   if (p^.right^.location.reference.base=R_ESI) or
-                      (p^.right^.location.reference.index=R_ESI) then
-                     begin
-                        del_reference(p^.right^.location.reference);
-{$ifndef noAllocEdi}
-                        getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                        emit_ref_reg(A_MOV,S_L,
-                          newreference(p^.right^.location.reference),R_EDI);
-                        hregister:=R_EDI;
-                     end;
-
-                   { load self, but not if it's already explicitly pushed }
-                   if not(po_containsself in p^.procdefinition^.procoptions) then
-                     begin
-                       { load ESI }
-                       inc(p^.right^.location.reference.offset,4);
-                       getexplicitregister32(R_ESI);
-                       emit_ref_reg(A_MOV,S_L,
-                         newreference(p^.right^.location.reference),R_ESI);
-                       dec(p^.right^.location.reference.offset,4);
-                       { push self pointer }
-                       emit_reg(A_PUSH,S_L,R_ESI);
-                     end;
-
-                   if hregister=R_NO then
-                     emit_ref(A_CALL,S_NO,newreference(p^.right^.location.reference))
-                   else
-                     begin
-{$ifndef noAllocEdi}
-                       ungetregister32(hregister);
-{$else noAllocEdi}
-                       { the same code, the previous line is just to       }
-                       { indicate EDI actually is deallocated if allocated }
-                       { above (JM)                                        }
-                       ungetregister32(hregister);
-{$endif noAllocEdi}
-                       emit_reg(A_CALL,S_NO,hregister);
-                     end;
-
-                   del_reference(p^.right^.location.reference);
-                end
-              else
-                begin
-                   case p^.right^.location.loc of
-                      LOC_REGISTER,LOC_CREGISTER:
-                         begin
-                             emit_reg(A_CALL,S_NO,p^.right^.location.register);
-                             ungetregister32(p^.right^.location.register);
-                         end
-                      else
-                         emit_ref(A_CALL,S_NO,newreference(p^.right^.location.reference));
-                         del_reference(p^.right^.location.reference);
-                   end;
-                end;
-           end;
-
-           { this was only for normal functions
-             displaced here so we also get
-             it to work for procvars PM }
-           if (not inlined) and (pocall_clearstack in p^.procdefinition^.proccalloptions) then
-             begin
-                { we also add the pop_size which is included in pushedparasize }
-                pop_size:=0;
-                { better than an add on all processors }
-                if pushedparasize=4 then
-                  begin
-{$ifndef noAllocEdi}
-                    getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                    emit_reg(A_POP,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                    ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                  end
-                { the pentium has two pipes and pop reg is pairable }
-                { but the registers must be different!        }
-                else if (pushedparasize=8) and
-                  not(cs_littlesize in aktglobalswitches) and
-                  (aktoptprocessor=ClassP5) and
-                  (procinfo^._class=nil) then
-                    begin
-{$ifndef noAllocEdi}
-                       getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                       emit_reg(A_POP,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                       ungetregister32(R_EDI);
-{$endif noAllocEdi}
-{$ifndef noAllocEdi}
-                       exprasmlist^.concat(new(pairegalloc,alloc(R_ESI)));
-{$endif noAllocEdi}
-                       emit_reg(A_POP,S_L,R_ESI);
-{$ifndef noAllocEdi}
-                       exprasmlist^.concat(new(pairegalloc,alloc(R_ESI)));
-{$endif noAllocEdi}
-                    end
-                else if pushedparasize<>0 then
-                  emit_const_reg(A_ADD,S_L,pushedparasize,R_ESP);
-             end;
-         if pop_esp then
-           emit_reg(A_POP,S_L,R_ESP);
-      dont_call:
-         pushedparasize:=oldpushedparasize;
-         unused:=unusedregisters;
-         usablereg32:=usablecount;
-{$ifdef TEMPREGDEBUG}
-         testregisters32;
-{$endif TEMPREGDEBUG}
-
-         { a constructor could be a function with boolean result }
-         { if calling constructor called fail we
-           must jump directly to quickexitlabel  PM
-           but only if it is a call of an inherited constructor }
-         if (inlined or
-             (p^.right=nil)) and
-            (p^.procdefinition^.proctypeoption=potype_constructor) and
-            assigned(p^.methodpointer) and
-            (p^.methodpointer^.treetype=typen) and
-            (aktprocsym^.definition^.proctypeoption=potype_constructor) then
-           begin
-             emitjmp(C_Z,faillabel);
-           end;
-         { handle function results }
-         { 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;
-              p^.location.reference.symbol:=nil;
-              p^.location.reference:=funcretref;
-           end;
-         { we have only to handle the result if it is used, but }
-         { ansi/widestrings must be registered, so we can dispose them }
-         if (p^.resulttype<>pdef(voiddef)) and (p^.return_value_used or
-           is_ansistring(p^.resulttype) or is_widestring(p^.resulttype)) then
-           begin
-              { a contructor could be a function with boolean result }
-              if (inlined or
-                  (p^.right=nil)) and
-                 (p^.procdefinition^.proctypeoption=potype_constructor) and
-                 { quick'n'dirty check if it is a class or an object }
-                 (p^.resulttype^.deftype=orddef) then
-                begin
-                   { this fails if popsize > 0 PM }
-                   p^.location.loc:=LOC_FLAGS;
-                   p^.location.resflags:=F_NE;
-
-
-                   if extended_new then
-                     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
-{$endif test_dest_loc}
-                          begin
-                             hregister:=getexplicitregister32(R_EAX);
-                             emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                             p^.location.register:=hregister;
-                          end;
-                     end;
-                end
-               { structed results are easy to handle.... }
-              else if ret_in_param(p^.resulttype) then
-                begin
-                   {p^.location.loc:=LOC_MEM;
-                   stringdispose(p^.location.reference.symbol);
-                   p^.location.reference:=funcretref;
-                   already done above (PM) }
-                end
-              else
-                begin
-                   if (p^.resulttype^.deftype in [orddef,enumdef]) then
-                     begin
-                        p^.location.loc:=LOC_REGISTER;
-                        case p^.resulttype^.size of
-                          4 :
-                            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
-{$endif test_dest_loc}
-                                 begin
-                                    hregister:=getexplicitregister32(R_EAX);
-                                    emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                                    p^.location.register:=hregister;
-                                 end;
-                            end;
-                          1 :
-                            begin
-{$ifdef test_dest_loc}
-                                 if dest_loc_known and (dest_loc_tree=p) then
-                                   mov_reg_to_dest(p,S_B,R_AL)
-                                 else
-{$endif test_dest_loc}
-                                   begin
-                                      hregister:=getexplicitregister32(R_EAX);
-                                      emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister));
-                                      p^.location.register:=reg32toreg8(hregister);
-                                   end;
-                              end;
-                          2 :
-                            begin
-{$ifdef test_dest_loc}
-                               if dest_loc_known and (dest_loc_tree=p) then
-                                 mov_reg_to_dest(p,S_W,R_AX)
-                               else
-{$endif test_dest_loc}
-                                 begin
-                                    hregister:=getexplicitregister32(R_EAX);
-                                    emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister));
-                                    p^.location.register:=reg32toreg16(hregister);
-                                 end;
-                            end;
-                           8 :
-                             begin
-{$ifdef test_dest_loc}
-{$error Don't know what to do here}
-{$endif test_dest_loc}
-                                hregister:=getexplicitregister32(R_EAX);
-                                hregister2:=getexplicitregister32(R_EDX);
-                                emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                                emit_reg_reg(A_MOV,S_L,R_EDX,hregister2);
-                                p^.location.registerlow:=hregister;
-                                p^.location.registerhigh:=hregister2;
-                             end;
-                        else internalerror(7);
-                     end
-
-                end
-              else if (p^.resulttype^.deftype=floatdef) then
-                case pfloatdef(p^.resulttype)^.typ of
-                  f32bit:
-                    begin
-                       p^.location.loc:=LOC_REGISTER;
-{$ifdef test_dest_loc}
-                       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:=getexplicitregister32(R_EAX);
-                            emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                            p^.location.register:=hregister;
-                         end;
-                    end;
-                  else
-                    begin
-                       p^.location.loc:=LOC_FPU;
-                       inc(fpuvaroffset);
-                    end;
-                end
-              else if is_ansistring(p^.resulttype) or
-                is_widestring(p^.resulttype) then
-                begin
-                   hregister:=getexplicitregister32(R_EAX);
-                   emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                   gettempansistringreference(hr);
-                   decrstringref(p^.resulttype,hr);
-                   emit_reg_ref(A_MOV,S_L,hregister,
-                     newreference(hr));
-                   ungetregister32(hregister);
-                   p^.location.loc:=LOC_MEM;
-                   p^.location.reference:=hr;
-                end
-              else
-                begin
-                   p^.location.loc:=LOC_REGISTER;
-{$ifdef test_dest_loc}
-                   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:=getexplicitregister32(R_EAX);
-                       emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                       p^.location.register:=hregister;
-                    end;
-                end;
-             end;
-           end;
-
-         { perhaps i/o check ? }
-         if iolabel<>nil then
-           begin
-              emit_sym(A_PUSH,S_L,iolabel);
-              emitcall('FPC_IOCHECK');
-           end;
-         if pop_size>0 then
-           emit_const_reg(A_ADD,S_L,pop_size,R_ESP);
-
-         { restore registers }
-         popusedregisters(pushed);
-
-         { at last, restore instance pointer (SELF) }
-         if loadesi then
-           maybe_loadesi;
-         pp:=params;
-         while assigned(pp) do
-           begin
-              if assigned(pp^.left) then
-                begin
-                  if (pp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) then
-                    ungetiftemp(pp^.left^.location.reference);
-                { process also all nodes of an array of const }
-                  if pp^.left^.treetype=arrayconstructn then
-                    begin
-                      if assigned(pp^.left^.left) then
-                       begin
-                         hp:=pp^.left;
-                         while assigned(hp) do
-                          begin
-                            if (hp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) then
-                              ungetiftemp(hp^.left^.location.reference);
-                            hp:=hp^.right;
-                          end;
-                       end;
-                    end;
-                end;
-              pp:=pp^.right;
-           end;
-         if inlined then
-           ungetpersistanttemp(inlinecode^.retoffset);
-         if assigned(inlinecode) then
-           disposetree(inlinecode);
-         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
-                begin
-                   { data which must be finalized ? }
-                   if (p^.resulttype^.needs_inittable) and
-                     ( (p^.resulttype^.deftype<>objectdef) or
-                       not(pobjectdef(p^.resulttype)^.is_class)) then
-                      finalize(p^.resulttype,p^.location.reference,false);
-                   { release unused temp }
-                   ungetiftemp(p^.location.reference)
-                end
-              else if p^.location.loc=LOC_FPU then
-                begin
-                  { release FPU stack }
-                  emit_reg(A_FSTP,S_NO,R_ST0);
-                  {
-                    dec(fpuvaroffset);
-                    do NOT decrement as the increment before
-                    is not called for unused results PM }
-                end;
-           end;
-      end;
-
-
-{*****************************************************************************
-                             SecondProcInlineN
-*****************************************************************************}
-
-
-    procedure secondprocinline(var p : ptree);
-       var st : psymtable;
-           oldprocsym : pprocsym;
-           para_size, i : longint;
-           tmpreg: tregister;
-           oldprocinfo : pprocinfo;
-           oldinlining_procedure,
-           nostackframe,make_global : boolean;
-           proc_names : tstringcontainer;
-           inlineentrycode,inlineexitcode : paasmoutput;
-           oldexitlabel,oldexit2label,oldquickexitlabel:Pasmlabel;
-           oldunused,oldusableregs : tregisterset;
-           oldc_usableregs : longint;
-           oldreg_pushes : regvar_longintarray;
-           oldis_reg_var : regvar_booleanarray;
-{$ifdef TEMPREGDEBUG}
-           oldreg_user   : regvar_ptreearray;
-           oldreg_releaser : regvar_ptreearray;
-{$endif TEMPREGDEBUG}
-{$ifdef GDB}
-           startlabel,endlabel : pasmlabel;
-           pp : pchar;
-           mangled_length  : longint;
-{$endif GDB}
-       begin
-          { deallocate the registers used for the current procedure's regvars }
-          if assigned(aktprocsym^.definition^.regvarinfo) then
-            begin
-              with pregvarinfo(aktprocsym^.definition^.regvarinfo)^ do
-                for i := 1 to maxvarregs do
-                  if assigned(regvars[i]) then
-                    begin
-                      case regsize(regvars[i]^.reg) of
-                        S_B: tmpreg := reg8toreg32(regvars[i]^.reg);
-                        S_W: tmpreg := reg16toreg32(regvars[i]^.reg);
-                        S_L: tmpreg := regvars[i]^.reg;
-                      end;
-                      exprasmlist^.concat(new(pairegalloc,dealloc(tmpreg)));
-                    end;
-              oldunused := unused;
-              oldusableregs := usableregs;
-              oldc_usableregs := c_usableregs;
-              oldreg_pushes := reg_pushes;
-              oldis_reg_var := is_reg_var;
-{$ifdef TEMPREGDEBUG}
-              oldreg_user := reg_user;
-              oldreg_releaser := reg_releaser;
-{$endif TEMPREGDEBUG}
-              { make sure the register allocator knows what the regvars in the }
-              { inlined code block are (JM)                                    }
-              resetusableregisters;
-              clearregistercount;
-              cleartempgen;
-              if assigned(p^.inlineprocsym^.definition^.regvarinfo) then
-                with pregvarinfo(p^.inlineprocsym^.definition^.regvarinfo)^ do
-                 for i := 1 to maxvarregs do
-                  if assigned(regvars[i]) then
-                    begin
-                      case regsize(regvars[i]^.reg) of
-                        S_B: tmpreg := reg8toreg32(regvars[i]^.reg);
-                        S_W: tmpreg := reg16toreg32(regvars[i]^.reg);
-                        S_L: tmpreg := regvars[i]^.reg;
-                      end;
-                      usableregs:=usableregs-[tmpreg];
-                      is_reg_var[tmpreg]:=true;
-                      dec(c_usableregs);
-                    end;
-            end;
-          oldinlining_procedure:=inlining_procedure;
-          oldexitlabel:=aktexitlabel;
-          oldexit2label:=aktexit2label;
-          oldquickexitlabel:=quickexitlabel;
-          getlabel(aktexitlabel);
-          getlabel(aktexit2label);
-          oldprocsym:=aktprocsym;
-          { we're inlining a procedure }
-          inlining_procedure:=true;
-          { save old procinfo }
-          getmem(oldprocinfo,sizeof(tprocinfo));
-          move(procinfo^,oldprocinfo^,sizeof(tprocinfo));
-          { set the return value }
-          aktprocsym:=p^.inlineprocsym;
-          procinfo^.returntype:=aktprocsym^.definition^.rettype;
-          procinfo^.return_offset:=p^.retoffset;
-          procinfo^.para_offset:=p^.para_offset;
-          { arg space has been filled by the parent secondcall }
-          st:=aktprocsym^.definition^.localst;
-          { set it to the same lexical level }
-          st^.symtablelevel:=oldprocsym^.definition^.localst^.symtablelevel;
-          if st^.datasize>0 then
-            begin
-              st^.address_fixup:=gettempofsizepersistant(st^.datasize)+st^.datasize;
-{$ifdef extdebug}
-              Comment(V_debug,'local symtable is at offset '+tostr(st^.address_fixup));
-              exprasmlist^.concat(new(pai_asm_comment,init(strpnew(
-                'local symtable is at offset '+tostr(st^.address_fixup)))));
-{$endif extdebug}
-            end;
-          exprasmlist^.concat(new(Pai_Marker, Init(InlineStart)));
-{$ifdef extdebug}
-          exprasmlist^.concat(new(pai_asm_comment,init(strpnew('Start of inlined proc'))));
-{$endif extdebug}
-{$ifdef GDB}
-          if (cs_debuginfo in aktmoduleswitches) then
-            begin
-              getaddrlabel(startlabel);
-              getaddrlabel(endlabel);
-              emitlab(startlabel);
-              p^.inlineprocsym^.definition^.localst^.symtabletype:=inlinelocalsymtable;
-              p^.inlineprocsym^.definition^.parast^.symtabletype:=inlineparasymtable;
-
-              { Here we must include the para and local symtable info }
-              p^.inlineprocsym^.concatstabto(withdebuglist);
-
-              { set it back for savety }
-              p^.inlineprocsym^.definition^.localst^.symtabletype:=localsymtable;
-              p^.inlineprocsym^.definition^.parast^.symtabletype:=parasymtable;
-
-              mangled_length:=length(oldprocsym^.definition^.mangledname);
-              getmem(pp,mangled_length+50);
-              strpcopy(pp,'192,0,0,'+startlabel^.name);
-              if (target_os.use_function_relative_addresses) then
-                begin
-                  strpcopy(strend(pp),'-');
-                  strpcopy(strend(pp),oldprocsym^.definition^.mangledname);
-                end;
-              withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
-            end;
-{$endif GDB}
-          { takes care of local data initialization }
-          inlineentrycode:=new(paasmoutput,init);
-          inlineexitcode:=new(paasmoutput,init);
-          proc_names.init;
-          para_size:=p^.para_size;
-          make_global:=false; { to avoid warning }
-          genentrycode(inlineentrycode,proc_names,make_global,0,para_size,nostackframe,true);
-          exprasmlist^.concatlist(inlineentrycode);
-          secondpass(p^.inlinetree);
-          genexitcode(inlineexitcode,0,false,true);
-          exprasmlist^.concatlist(inlineexitcode);
-
-          dispose(inlineentrycode,done);
-          dispose(inlineexitcode,done);
-{$ifdef extdebug}
-          exprasmlist^.concat(new(pai_asm_comment,init(strpnew('End of inlined proc'))));
-{$endif extdebug}
-          exprasmlist^.concat(new(Pai_Marker, Init(InlineEnd)));
-
-          {we can free the local data now, reset also the fixup address }
-          if st^.datasize>0 then
-            begin
-              ungetpersistanttemp(st^.address_fixup-st^.datasize);
-              st^.address_fixup:=0;
-            end;
-          { restore procinfo }
-          move(oldprocinfo^,procinfo^,sizeof(tprocinfo));
-          freemem(oldprocinfo,sizeof(tprocinfo));
-{$ifdef GDB}
-          if (cs_debuginfo in aktmoduleswitches) then
-            begin
-              emitlab(endlabel);
-              strpcopy(pp,'224,0,0,'+endlabel^.name);
-             if (target_os.use_function_relative_addresses) then
-               begin
-                 strpcopy(strend(pp),'-');
-                 strpcopy(strend(pp),oldprocsym^.definition^.mangledname);
-               end;
-              withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
-              freemem(pp,mangled_length+50);
-            end;
-{$endif GDB}
-          { restore }
-          aktprocsym:=oldprocsym;
-          aktexitlabel:=oldexitlabel;
-          aktexit2label:=oldexit2label;
-          quickexitlabel:=oldquickexitlabel;
-          inlining_procedure:=oldinlining_procedure;
-
-          { reallocate the registers used for the current procedure's regvars, }
-          { since they may have been used and then deallocated in the inlined  }
-          { procedure (JM)                                                     }
-          if assigned(aktprocsym^.definition^.regvarinfo) then
-            begin
-              with pregvarinfo(aktprocsym^.definition^.regvarinfo)^ do
-                for i := 1 to maxvarregs do
-                  if assigned(regvars[i]) then
-                    begin
-                      case regsize(regvars[i]^.reg) of
-                        S_B: tmpreg := reg8toreg32(regvars[i]^.reg);
-                        S_W: tmpreg := reg16toreg32(regvars[i]^.reg);
-                        S_L: tmpreg := regvars[i]^.reg;
-                      end;
-                      exprasmlist^.concat(new(pairegalloc,alloc(tmpreg)));
-                    end;
-              oldunused := oldunused;
-              oldusableregs := oldusableregs;
-              oldc_usableregs := oldc_usableregs;
-              oldreg_pushes := oldreg_pushes;
-              oldis_reg_var := oldis_reg_var;
-{$ifdef TEMPREGDEBUG}
-              oldreg_user := oldreg_user;
-              oldreg_releaser := oldreg_releaser;
-{$endif TEMPREGDEBUG}
-            end;
-       end;
-
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.11  2000/09/24 21:19:48  peter
-    * delphi compile fixes
-
-  Revision 1.10  2000/09/19 23:09:07  pierre
-   * problems wih extdebug cond. solved
-
-  Revision 1.9  2000/09/16 12:21:56  peter
-    * fixed for with and local object loading
-
-  Revision 1.8  2000/09/10 20:18:06  peter
-    * fixed open array with cdecl
-    * fixed finalize call with unused function return
-
-  Revision 1.7  2000/08/03 14:27:04  jonas
-    * save/reset/restore regvar info around inlined code
-
-  Revision 1.5  2000/07/27 13:03:35  jonas
-    * release alignopts
-
-  Revision 1.4  2000/07/21 15:14:01  jonas
-    + added is_addr field for labels, if they are only used for getting the address
-       (e.g. for io checks) and corresponding getaddrlabel() procedure
-
-  Revision 1.3  2000/07/13 12:08:24  michael
-  + patched to 1.1.0 with former 1.09patch from peter
-
-  Revision 1.2  2000/07/13 11:32:32  michael
-  + removed logs
-
-}

compiler/old/cg386cnv.pas

@@ -1,1598 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for type converting nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386cnv;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure loadshortstring(p:ptree);
-    procedure loadlongstring(p:ptree);
-    procedure loadansi2short(source,dest : ptree);
-
-    procedure secondtypeconv(var p : ptree);
-    procedure secondas(var p : ptree);
-    procedure secondis(var p : ptree);
-
-
-implementation
-
-   uses
-      cobjects,verbose,globtype,globals,systems,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,pass_1,
-      cpubase,cpuasm,
-      cgai386,tgeni386;
-
-
-
-    procedure push_shortstring_length(p:ptree);
-      var
-        hightree : ptree;
-      begin
-        if is_open_string(p^.resulttype) then
-         begin
-           getsymonlyin(p^.symtable,'high'+pvarsym(p^.symtableentry)^.name);
-           hightree:=genloadnode(pvarsym(srsym),p^.symtable);
-           firstpass(hightree);
-           secondpass(hightree);
-           push_value_para(hightree,false,false,0,4);
-           disposetree(hightree);
-         end
-        else
-         begin
-           push_int(pstringdef(p^.resulttype)^.len);
-         end;
-      end;
-
-
-    procedure loadshortstring(p:ptree);
-    {
-      Load a string, handles stringdef and orddef (char) types
-    }
-      begin
-         case p^.right^.resulttype^.deftype of
-            stringdef:
-              begin
-                 if (p^.right^.treetype=stringconstn) and
-                   (str_length(p^.right)=0) then
-                   emit_const_ref(
-                      A_MOV,S_B,0,newreference(p^.left^.location.reference))
-                 else
-                   begin
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                     emitpushreferenceaddr(p^.right^.location.reference);
-                     push_shortstring_length(p^.left);
-                     emitcall('FPC_SHORTSTR_COPY');
-                     maybe_loadesi;
-                   end;
-              end;
-            orddef:
-              begin
-                 if p^.right^.treetype=ordconstn then
-                   emit_const_ref(
-                      A_MOV,S_W,p^.right^.value*256+1,newreference(p^.left^.location.reference))
-                 else
-                   begin
-                      { not so elegant (goes better with extra register }
-{$ifndef noAllocEdi}
-                      getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                      if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                        begin
-                           emit_reg_reg(A_MOV,S_L,makereg32(p^.right^.location.register),R_EDI);
-                           ungetregister(p^.right^.location.register);
-                        end
-                      else
-                        begin
-                           emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI);
-                           del_reference(p^.right^.location.reference);
-                        end;
-                      emit_const_reg(A_SHL,S_L,8,R_EDI);
-                      emit_const_reg(A_OR,S_L,1,R_EDI);
-                      emit_reg_ref(A_MOV,S_W,R_DI,newreference(p^.left^.location.reference));
-{$ifndef noAllocEdi}
-                      ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                   end;
-              end;
-         else
-           CGMessage(type_e_mismatch);
-         end;
-      end;
-
-    procedure loadlongstring(p:ptree);
-    {
-      Load a string, handles stringdef and orddef (char) types
-    }
-      var
-         r : preference;
-
-      begin
-         case p^.right^.resulttype^.deftype of
-            stringdef:
-              begin
-                 if (p^.right^.treetype=stringconstn) and
-                   (str_length(p^.right)=0) then
-                   emit_const_ref(A_MOV,S_L,0,newreference(p^.left^.location.reference))
-                 else
-                   begin
-                     emitpushreferenceaddr(p^.left^.location.reference);
-                     emitpushreferenceaddr(p^.right^.location.reference);
-                     push_shortstring_length(p^.left);
-                     emitcall('FPC_LONGSTR_COPY');
-                     maybe_loadesi;
-                   end;
-              end;
-            orddef:
-              begin
-                 emit_const_ref(A_MOV,S_L,1,newreference(p^.left^.location.reference));
-
-                 r:=newreference(p^.left^.location.reference);
-                 inc(r^.offset,4);
-
-                 if p^.right^.treetype=ordconstn then
-                   emit_const_ref(A_MOV,S_B,p^.right^.value,r)
-                 else
-                   begin
-                      case p^.right^.location.loc of
-                         LOC_REGISTER,LOC_CREGISTER:
-                           begin
-                              emit_reg_ref(A_MOV,S_B,p^.right^.location.register,r);
-                              ungetregister(p^.right^.location.register);
-                           end;
-                         LOC_MEM,LOC_REFERENCE:
-                           begin
-                              if not(R_EAX in unused) then
-                                emit_reg(A_PUSH,S_L,R_EAX);
-                              emit_ref_reg(A_MOV,S_B,newreference(p^.right^.location.reference),R_AL);
-                              emit_reg_ref(A_MOV,S_B,R_AL,r);
-
-                              if not(R_EAX in unused) then
-                                emit_reg(A_POP,S_L,R_EAX);
-                              del_reference(p^.right^.location.reference);
-                           end
-                         else
-                           internalerror(20799);
-                        end;
-                   end;
-              end;
-         else
-           CGMessage(type_e_mismatch);
-         end;
-      end;
-
-
-    procedure loadansi2short(source,dest : ptree);
-      var
-         pushed : tpushed;
-         regs_to_push: byte;
-      begin
-         { Find out which registers have to be pushed (JM) }
-         regs_to_push := $ff;
-         remove_non_regvars_from_loc(source^.location,regs_to_push);
-         { Push them (JM) }
-         pushusedregisters(pushed,regs_to_push);
-         case source^.location.loc of
-           LOC_REFERENCE,LOC_MEM:
-             begin
-                { Now release the location and registers (see cgai386.pas: }
-                { loadansistring for more info on the order) (JM)          }
-                ungetiftemp(source^.location.reference);
-                del_reference(source^.location.reference);
-                emit_push_mem(source^.location.reference);
-             end;
-           LOC_REGISTER,LOC_CREGISTER:
-             begin
-                emit_reg(A_PUSH,S_L,source^.location.register);
-                { Now release the register (JM) }
-                ungetregister32(source^.location.register);
-             end;
-         end;
-         push_shortstring_length(dest);
-         emitpushreferenceaddr(dest^.location.reference);
-         emitcall('FPC_ANSISTR_TO_SHORTSTR');
-         popusedregisters(pushed);
-         maybe_loadesi;
-      end;
-
-
-
-{*****************************************************************************
-                             SecondTypeConv
-*****************************************************************************}
-
-    type
-      tsecondconvproc = procedure(var pto,pfrom : ptree;convtyp : tconverttype);
-
-    procedure second_int_to_int(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        op      : tasmop;
-        opsize    : topsize;
-        hregister,
-        hregister2 : tregister;
-        l : pasmlabel;
-
-      begin
-        { insert range check if not explicit conversion }
-        if not(pto^.explizit) then
-          emitrangecheck(pfrom,pto^.resulttype);
-
-        { is the result size smaller ? }
-        if pto^.resulttype^.size<pfrom^.resulttype^.size then
-          begin
-            { only need to set the new size of a register }
-            if (pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-             begin
-               case pto^.resulttype^.size of
-                1 : pto^.location.register:=makereg8(pfrom^.location.register);
-                2 : pto^.location.register:=makereg16(pfrom^.location.register);
-                4 : pto^.location.register:=makereg32(pfrom^.location.register);
-               end;
-               { we can release the upper register }
-               if is_64bitint(pfrom^.resulttype) then
-                 ungetregister32(pfrom^.location.registerhigh);
-             end;
-          end
-
-        { is the result size bigger ? }
-        else if pto^.resulttype^.size>pfrom^.resulttype^.size then
-          begin
-            { remove reference }
-            if not(pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-              begin
-                del_reference(pfrom^.location.reference);
-                { we can do this here as we need no temp inside }
-                ungetiftemp(pfrom^.location.reference);
-              end;
-
-            { get op and opsize, handle separate for constants, because
-              movz doesn't support constant values }
-            if (pfrom^.location.loc=LOC_MEM) and (pfrom^.location.reference.is_immediate) then
-             begin
-               if is_64bitint(pto^.resulttype) then
-                 opsize:=S_L
-               else
-                 opsize:=def_opsize(pto^.resulttype);
-               op:=A_MOV;
-             end
-            else
-             begin
-               opsize:=def2def_opsize(pfrom^.resulttype,pto^.resulttype);
-               if opsize in [S_B,S_W,S_L] then
-                op:=A_MOV
-               else
-                if is_signed(pfrom^.resulttype) then
-                 op:=A_MOVSX
-                else
-                 op:=A_MOVZX;
-             end;
-            { load the register we need }
-            if pfrom^.location.loc<>LOC_REGISTER then
-              hregister:=getregister32
-            else
-              hregister:=pfrom^.location.register;
-
-            { set the correct register size and location }
-            clear_location(pto^.location);
-            pto^.location.loc:=LOC_REGISTER;
-
-            { do we need a second register for a 64 bit type ? }
-            if is_64bitint(pto^.resulttype) then
-              begin
-                 hregister2:=getregister32;
-                 pto^.location.registerhigh:=hregister2;
-              end;
-            case pto^.resulttype^.size of
-             1:
-               pto^.location.register:=makereg8(hregister);
-             2:
-               pto^.location.register:=makereg16(hregister);
-             4,8:
-               pto^.location.register:=makereg32(hregister);
-            end;
-            { insert the assembler code }
-            if pfrom^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
-              emit_reg_reg(op,opsize,pfrom^.location.register,pto^.location.register)
-            else
-              emit_ref_reg(op,opsize,
-                newreference(pfrom^.location.reference),pto^.location.register);
-
-            { do we need a sign extension for int64? }
-            if is_64bitint(pto^.resulttype) then
-              begin
-                 emit_reg_reg(A_XOR,S_L,
-                   hregister2,hregister2);
-                 if (porddef(pto^.resulttype)^.typ=s64bit) and
-                   is_signed(pfrom^.resulttype) then
-                   begin
-                      getlabel(l);
-                      emit_const_reg(A_TEST,S_L,$80000000,makereg32(hregister));
-                      emitjmp(C_Z,l);
-                      emit_reg(A_NOT,S_L,
-                        hregister2);
-                      emitlab(l);
-                   end;
-              end;
-          end;
-      end;
-
-    procedure second_string_to_string(var pto,pfrom : ptree;convtyp : tconverttype);
-
-      var
-         pushed : tpushed;
-         regs_to_push: byte;
-
-      begin
-         { does anybody know a better solution than this big case statement ? }
-         { ok, a proc table would do the job                              }
-         case pstringdef(pto^.resulttype)^.string_typ of
-
-            st_shortstring:
-              case pstringdef(pfrom^.resulttype)^.string_typ of
-                 st_shortstring:
-                   begin
-                      gettempofsizereference(pto^.resulttype^.size,pto^.location.reference);
-                      copyshortstring(pto^.location.reference,pfrom^.location.reference,
-                        pstringdef(pto^.resulttype)^.len,false,true);
-{                      done by copyshortstring now (JM)          }
-{                      del_reference(pfrom^.location.reference); }
-                      ungetiftemp(pfrom^.location.reference);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      gettempofsizereference(pto^.resulttype^.size,pto^.location.reference);
-                      loadansi2short(pfrom,pto);
-                      { this is done in secondtypeconv (FK)
-                      removetemps(exprasmlist,temptoremove);
-                      destroys:=true;
-                      }
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_longstring:
-              case pstringdef(pfrom^.resulttype)^.string_typ of
-                 st_shortstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_ansistring:
-              case pstringdef(pfrom^.resulttype)^.string_typ of
-                 st_shortstring:
-                   begin
-                      clear_location(pto^.location);
-                      pto^.location.loc:=LOC_REFERENCE;
-                      gettempansistringreference(pto^.location.reference);
-                      decrstringref(cansistringdef,pto^.location.reference);
-                      { We don't need the source regs anymore (JM) }
-                      regs_to_push := $ff;
-                      remove_non_regvars_from_loc(pfrom^.location,regs_to_push);
-                      pushusedregisters(pushed,regs_to_push);
-                      release_loc(pfrom^.location);
-                      emit_push_lea_loc(pfrom^.location,true);
-                      emit_push_lea_loc(pto^.location,false);
-                      emitcall('FPC_SHORTSTR_TO_ANSISTR');
-                      maybe_loadesi;
-                      popusedregisters(pushed);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_widestring:
-              case pstringdef(pfrom^.resulttype)^.string_typ of
-                 st_shortstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-         end;
-      end;
-
-
-    procedure second_cstring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        hr : preference;
-      begin
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         pto^.location.register:=getregister32;
-         case pstringdef(pfrom^.resulttype)^.string_typ of
-           st_shortstring :
-             begin
-               inc(pfrom^.location.reference.offset);
-               emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference),
-                 pto^.location.register);
-             end;
-           st_ansistring :
-             begin
-               if (pfrom^.treetype=stringconstn) and
-                  (str_length(pfrom)=0) then
-                begin
-                  new(hr);
-                  reset_reference(hr^);
-                  hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
-                  emit_ref_reg(A_LEA,S_L,hr,pto^.location.register);
-                end
-               else
-                emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference),
-                  pto^.location.register);
-             end;
-           st_longstring:
-             begin
-               {!!!!!!!}
-               internalerror(8888);
-             end;
-           st_widestring:
-             begin
-               {!!!!!!!}
-               internalerror(8888);
-             end;
-         end;
-      end;
-
-
-    procedure second_string_to_chararray(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         pushedregs: tpushed;
-         l1 : pasmlabel;
-         hr : preference;
-         arrsize, strtype: longint;
-         regstopush: byte;
-      begin
-         with parraydef(pto^.resulttype)^ do
-           arrsize := highrange-lowrange+1;
-
-         if (pfrom^.treetype = stringconstn) and
-            { pfrom^.length+1 since there's always a terminating #0 character (JM) }
-            (pfrom^.length+1 >= arrsize) and
-            (pstringdef(pfrom^.resulttype)^.string_typ=st_shortstring) then
-           begin
-             inc(pto^.location.reference.offset);
-             exit;
-           end;
-         clear_location(pto^.location);
-         pto^.location.loc := LOC_REFERENCE;
-         gettempofsizereference(arrsize,pto^.location.reference);
-
-         regstopush := $ff;
-         remove_non_regvars_from_loc(pfrom^.location,regstopush);
-         pushusedregisters(pushedregs,regstopush);
-
-         emit_push_lea_loc(pto^.location,false);
-
-         case pstringdef(pfrom^.resulttype)^.string_typ of
-           st_shortstring :
-             begin
-               { 0 means shortstring }
-               strtype := 0;
-               del_reference(pfrom^.location.reference);
-               emit_push_lea_loc(pfrom^.location,true);
-               ungetiftemp(pfrom^.location.reference);
-             end;
-           st_ansistring :
-             begin
-               { 1 means ansistring }
-               strtype := 1;
-               case pfrom^.location.loc of
-                  LOC_CREGISTER,LOC_REGISTER:
-                    begin
-                      ungetregister(pfrom^.location.register);
-                      emit_push_loc(pfrom^.location);
-                    end;
-                  LOC_MEM,LOC_REFERENCE:
-                    begin
-                      del_reference(pfrom^.location.reference);
-                      emit_push_loc(pfrom^.location);
-                      ungetiftemp(pfrom^.location.reference);
-                    end;
-               end;
-             end;
-           st_longstring:
-             begin
-               {!!!!!!!}
-               { 2 means longstring, but still needs support in FPC_STR_TO_CHARARRAY,
-                 which is in i386.inc and/or generic.inc (JM) }
-               strtype := 2;
-
-               internalerror(8888);
-             end;
-           st_widestring:
-             begin
-               {!!!!!!!}
-               { 3 means widestring, but still needs support in FPC_STR_TO_CHARARRAY,
-                 which is in i386.inc and/or generic.inc (JM) }
-               strtype := 3;
-               internalerror(8888);
-             end;
-         end;
-         push_int(arrsize);
-         push_int(strtype);
-         emitcall('FPC_STR_TO_CHARARRAY');
-         popusedregisters(pushedregs);
-      end;
-
-
-    procedure second_array_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-         del_reference(pfrom^.location.reference);
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         pto^.location.register:=getregister32;
-         emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference),
-           pto^.location.register);
-      end;
-
-
-    procedure second_pointer_to_array(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-        clear_location(pto^.location);
-        pto^.location.loc:=LOC_REFERENCE;
-        reset_reference(pto^.location.reference);
-        case pfrom^.location.loc of
-          LOC_REGISTER :
-            pto^.location.reference.base:=pfrom^.location.register;
-          LOC_CREGISTER :
-            begin
-              pto^.location.reference.base:=getregister32;
-              emit_reg_reg(A_MOV,S_L,pfrom^.location.register,pto^.location.reference.base);
-            end
-         else
-            begin
-              del_reference(pfrom^.location.reference);
-              pto^.location.reference.base:=getregister32;
-              emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference),
-                pto^.location.reference.base);
-            end;
-        end;
-      end;
-
-
-    { generates the code for the type conversion from an array of char }
-    { to a string                                                       }
-    procedure second_chararray_to_string(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         pushed : tpushed;
-         regstopush: byte;
-         l : longint;
-      begin
-         { calc the length of the array }
-         l:=parraydef(pfrom^.resulttype)^.highrange-parraydef(pfrom^.resulttype)^.lowrange+1;
-         { this is a type conversion which copies the data, so we can't }
-         { return a reference                                        }
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_MEM;
-         case pstringdef(pto^.resulttype)^.string_typ of
-           st_shortstring :
-             begin
-               if l>255 then
-                begin
-                  CGMessage(type_e_mismatch);
-                  l:=255;
-                end;
-               gettempofsizereference(pto^.resulttype^.size,pto^.location.reference);
-               { we've also to release the registers ... }
-               { Yes, but before pushusedregisters since that one resets unused! }
-               { This caused web bug 1073 (JM)                                   }
-               regstopush := $ff;
-               remove_non_regvars_from_loc(pfrom^.location,regstopush);
-               pushusedregisters(pushed,regstopush);
-               if l>=pto^.resulttype^.size then
-                 push_int(pto^.resulttype^.size-1)
-               else
-                 push_int(l);
-               { ... here only the temp. location is released }
-               emit_push_lea_loc(pfrom^.location,true);
-               del_reference(pfrom^.location.reference);
-               emitpushreferenceaddr(pto^.location.reference);
-               emitcall('FPC_CHARARRAY_TO_SHORTSTR');
-               maybe_loadesi;
-               popusedregisters(pushed);
-             end;
-           st_ansistring :
-             begin
-               gettempansistringreference(pto^.location.reference);
-               decrstringref(cansistringdef,pto^.location.reference);
-               regstopush := $ff;
-               remove_non_regvars_from_loc(pfrom^.location,regstopush);
-               pushusedregisters(pushed,regstopush);
-               push_int(l);
-               emitpushreferenceaddr(pfrom^.location.reference);
-               release_loc(pfrom^.location);
-               emitpushreferenceaddr(pto^.location.reference);
-               emitcall('FPC_CHARARRAY_TO_ANSISTR');
-               popusedregisters(pushed);
-               maybe_loadesi;
-             end;
-           st_longstring:
-             begin
-               {!!!!!!!}
-               internalerror(8888);
-             end;
-           st_widestring:
-             begin
-               {!!!!!!!}
-               internalerror(8888);
-             end;
-        end;
-      end;
-
-
-    procedure second_char_to_string(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        pushed : tpushed;
-      begin
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_MEM;
-         case pstringdef(pto^.resulttype)^.string_typ of
-           st_shortstring :
-             begin
-               gettempofsizereference(256,pto^.location.reference);
-               { call loadstring with correct left and right }
-               pto^.right:=pfrom;
-               pto^.left:=pto;
-               loadshortstring(pto);
-               pto^.left:=nil; { reset left tree, which is empty }
-               { pto^.right is not disposed for typeconv !! PM }
-               disposetree(pto^.right);
-               pto^.right:=nil;
-             end;
-           st_ansistring :
-             begin
-               gettempansistringreference(pto^.location.reference);
-               decrstringref(cansistringdef,pto^.location.reference);
-               release_loc(pfrom^.location);
-               pushusedregisters(pushed,$ff);
-               emit_pushw_loc(pfrom^.location);
-               emitpushreferenceaddr(pto^.location.reference);
-               emitcall('FPC_CHAR_TO_ANSISTR');
-               popusedregisters(pushed);
-               maybe_loadesi;
-             end;
-           else
-            internalerror(4179);
-        end;
-      end;
-
-
-    procedure second_int_to_real(var pto,pfrom : ptree;convtyp : tconverttype);
-
-      var
-         r : preference;
-         hregister : tregister;
-         l1,l2 : pasmlabel;
-
-      begin
-         { for u32bit a solution is to push $0 and to load a comp }
-         { does this first, it destroys maybe EDI }
-         hregister:=R_EDI;
-         if porddef(pfrom^.resulttype)^.typ=u32bit then
-            push_int(0);
-         if (pfrom^.location.loc=LOC_REGISTER) or
-            (pfrom^.location.loc=LOC_CREGISTER) then
-           begin
-{$ifndef noAllocEdi}
-              if not (porddef(pfrom^.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then
-                getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-              case porddef(pfrom^.resulttype)^.typ of
-                 s8bit : emit_reg_reg(A_MOVSX,S_BL,pfrom^.location.register,R_EDI);
-                 u8bit : emit_reg_reg(A_MOVZX,S_BL,pfrom^.location.register,R_EDI);
-                 s16bit : emit_reg_reg(A_MOVSX,S_WL,pfrom^.location.register,R_EDI);
-                 u16bit : emit_reg_reg(A_MOVZX,S_WL,pfrom^.location.register,R_EDI);
-                 u32bit,s32bit:
-                   hregister:=pfrom^.location.register;
-                 u64bit,s64bit:
-                   begin
-                      emit_reg(A_PUSH,S_L,pfrom^.location.registerhigh);
-                      hregister:=pfrom^.location.registerlow;
-                   end;
-              end;
-              ungetregister(pfrom^.location.register);
-           end
-         else
-           begin
-              r:=newreference(pfrom^.location.reference);
-{$ifndef noAllocEdi}
-              getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-              case porddef(pfrom^.resulttype)^.typ of
-                 s8bit:
-                   emit_ref_reg(A_MOVSX,S_BL,r,R_EDI);
-                 u8bit:
-                   emit_ref_reg(A_MOVZX,S_BL,r,R_EDI);
-                 s16bit:
-                   emit_ref_reg(A_MOVSX,S_WL,r,R_EDI);
-                 u16bit:
-                   emit_ref_reg(A_MOVZX,S_WL,r,R_EDI);
-                 u32bit,s32bit:
-                   emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                 u64bit,s64bit:
-                   begin
-                      inc(r^.offset,4);
-                      emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                      emit_reg(A_PUSH,S_L,R_EDI);
-                      r:=newreference(pfrom^.location.reference);
-                      emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                   end;
-              end;
-              del_reference(pfrom^.location.reference);
-              ungetiftemp(pfrom^.location.reference);
-           end;
-         { for 64 bit integers, the high dword is already pushed }
-         emit_reg(A_PUSH,S_L,hregister);
-{$ifndef noAllocEdi}
-         if hregister = R_EDI then
-           ungetregister32(R_EDI);
-{$endif noAllocEdi}
-         r:=new_reference(R_ESP,0);
-         case porddef(pfrom^.resulttype)^.typ of
-           u32bit:
-             begin
-                emit_ref(A_FILD,S_IQ,r);
-                emit_const_reg(A_ADD,S_L,8,R_ESP);
-             end;
-           s64bit:
-             begin
-                emit_ref(A_FILD,S_IQ,r);
-                emit_const_reg(A_ADD,S_L,8,R_ESP);
-             end;
-           u64bit:
-             begin
-                { unsigned 64 bit ints are harder to handle: }
-                { we load bits 0..62 and then check bit 63:  }
-                { if it is 1 then we add $80000000 000000000 }
-                { as double                                  }
-                inc(r^.offset,4);
-{$ifndef noAllocEdi}
-                getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                r:=new_reference(R_ESP,4);
-                emit_const_ref(A_AND,S_L,$7fffffff,r);
-                emit_const_reg(A_TEST,S_L,$80000000,R_EDI);
-{$ifndef noAllocEdi}
-                ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                r:=new_reference(R_ESP,0);
-                emit_ref(A_FILD,S_IQ,r);
-                getdatalabel(l1);
-                getlabel(l2);
-                emitjmp(C_Z,l2);
-                consts^.concat(new(pai_label,init(l1)));
-                { I got this constant from a test progtram (FK) }
-                consts^.concat(new(pai_const,init_32bit(0)));
-                consts^.concat(new(pai_const,init_32bit(1138753536)));
-                r:=new_reference(R_NO,0);
-                r^.symbol:=l1;
-                emit_ref(A_FADD,S_FL,r);
-                emitlab(l2);
-                emit_const_reg(A_ADD,S_L,8,R_ESP);
-             end
-           else
-             begin
-                emit_ref(A_FILD,S_IL,r);
-{$ifndef noAllocEdi}
-                getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                emit_reg(A_POP,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                ungetregister32(R_EDI);
-{$endif noAllocEdi}
-             end;
-         end;
-         inc(fpuvaroffset);
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure second_real_to_fix(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         rreg : tregister;
-         ref : treference;
-      begin
-         { real must be on fpu stack }
-         if (pfrom^.location.loc<>LOC_FPU) then
-           emit_ref(A_FLD,S_FL,newreference(pfrom^.location.reference));
-         push_int($1f3f);
-         push_int(65536);
-         reset_reference(ref);
-         ref.base:=R_ESP;
-
-         emit_ref(A_FIMUL,S_IL,newreference(ref));
-
-         ref.offset:=4;
-         emit_ref(A_FSTCW,S_NO,newreference(ref));
-
-         ref.offset:=6;
-         emit_ref(A_FLDCW,S_NO,newreference(ref));
-
-         ref.offset:=0;
-         emit_ref(A_FISTP,S_IL,newreference(ref));
-
-         ref.offset:=4;
-         emit_ref(A_FLDCW,S_NO,newreference(ref));
-
-         rreg:=getregister32;
-         emit_reg(A_POP,S_L,rreg);
-         { better than an add on all processors }
-{$ifndef noAllocEdi}
-         getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-         emit_reg(A_POP,S_L,R_EDI);
-{$ifndef noAllocEdi}
-         ungetregister32(R_EDI);
-{$endif noAllocEdi}
-
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         pto^.location.register:=rreg;
-         inc(fpuvaroffset);
-      end;
-
-
-    procedure second_real_to_real(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-         case pfrom^.location.loc of
-            LOC_FPU : ;
-            LOC_CFPUREGISTER:
-              begin
-                 pto^.location:=pfrom^.location;
-                 exit;
-              end;
-            LOC_MEM,
-            LOC_REFERENCE:
-              begin
-                 floatload(pfloatdef(pfrom^.resulttype)^.typ,
-                   pfrom^.location.reference);
-                 { we have to free the reference }
-                 del_reference(pfrom^.location.reference);
-              end;
-         end;
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure second_fix_to_real(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        popeax,popebx,popecx,popedx : boolean;
-        startreg : tregister;
-        hl : pasmlabel;
-        r : treference;
-      begin
-         if (pfrom^.location.loc=LOC_REGISTER) or
-            (pfrom^.location.loc=LOC_CREGISTER) then
-           begin
-              startreg:=pfrom^.location.register;
-              ungetregister(startreg);
-              popeax:=(startreg<>R_EAX) and not (R_EAX in unused);
-              if popeax then
-                emit_reg(A_PUSH,S_L,R_EAX);
-              { mov eax,eax is removed by emit_reg_reg }
-              emit_reg_reg(A_MOV,S_L,startreg,R_EAX);
-           end
-         else
-           begin
-              emit_ref_reg(A_MOV,S_L,newreference(
-                pfrom^.location.reference),R_EAX);
-              del_reference(pfrom^.location.reference);
-              startreg:=R_NO;
-           end;
-
-         popebx:=(startreg<>R_EBX) and not (R_EBX in unused);
-         if popebx then
-           emit_reg(A_PUSH,S_L,R_EBX);
-
-         popecx:=(startreg<>R_ECX) and not (R_ECX in unused);
-         if popecx then
-           emit_reg(A_PUSH,S_L,R_ECX);
-
-         popedx:=(startreg<>R_EDX) and not (R_EDX in unused);
-         if popedx then
-           emit_reg(A_PUSH,S_L,R_EDX);
-
-         emit_none(A_CDQ,S_NO);
-         emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX);
-         emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX);
-         emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX);
-         getlabel(hl);
-         emitjmp(C_Z,hl);
-         emit_const_reg(A_RCL,S_L,1,R_EBX);
-         emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX);
-         emit_const_reg(A_MOV,S_B,32,R_CL);
-         emit_reg_reg(A_SUB,S_B,R_DL,R_CL);
-         emit_reg_reg(A_SHL,S_L,R_CL,R_EAX);
-         emit_const_reg(A_ADD,S_W,1007,R_DX);
-         emit_const_reg(A_SHL,S_W,5,R_DX);
-         emit_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX);
-         emit_const_reg_reg(A_SHLD,S_L,20,R_EAX,R_EBX);
-
-         emit_const_reg(A_SHL,S_L,20,R_EAX);
-         emitlab(hl);
-         { better than an add on all processors }
-         emit_reg(A_PUSH,S_L,R_EBX);
-         emit_reg(A_PUSH,S_L,R_EAX);
-
-         reset_reference(r);
-         r.base:=R_ESP;
-         emit_ref(A_FLD,S_FL,newreference(r));
-         emit_const_reg(A_ADD,S_L,8,R_ESP);
-         if popedx then
-           emit_reg(A_POP,S_L,R_EDX);
-         if popecx then
-           emit_reg(A_POP,S_L,R_ECX);
-         if popebx then
-           emit_reg(A_POP,S_L,R_EBX);
-         if popeax then
-           emit_reg(A_POP,S_L,R_EAX);
-
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure second_cord_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-        { this can't happend, because constants are already processed in
-          pass 1 }
-        internalerror(47423985);
-      end;
-
-
-    procedure second_int_to_fix(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         hregister : tregister;
-      begin
-         if (pfrom^.location.loc=LOC_REGISTER) then
-           hregister:=pfrom^.location.register
-         else if (pfrom^.location.loc=LOC_CREGISTER) then
-           hregister:=getregister32
-         else
-           begin
-              del_reference(pfrom^.location.reference);
-              hregister:=getregister32;
-              case porddef(pfrom^.resulttype)^.typ of
-                s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(pfrom^.location.reference),
-                  hregister);
-                u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(pfrom^.location.reference),
-                  hregister);
-                s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(pfrom^.location.reference),
-                  hregister);
-                u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(pfrom^.location.reference),
-                  hregister);
-                u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference),
-                  hregister);
-                {!!!! u32bit }
-              end;
-           end;
-         emit_const_reg(A_SHL,S_L,16,hregister);
-
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         pto^.location.register:=hregister;
-      end;
-
-
-    procedure second_proc_to_procvar(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-        { method pointer ? }
-        if assigned(pfrom^.left) then
-          begin
-             set_location(pto^.location,pfrom^.location);
-          end
-        else
-          begin
-             clear_location(pto^.location);
-             pto^.location.loc:=LOC_REGISTER;
-             pto^.location.register:=getregister32;
-             del_reference(pfrom^.location.reference);
-             emit_ref_reg(A_LEA,S_L,
-               newreference(pfrom^.location.reference),pto^.location.register);
-          end;
-      end;
-
-
-    procedure second_bool_to_int(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         oldtruelabel,oldfalselabel,hlabel : pasmlabel;
-         hregister : tregister;
-         newsize,
-         opsize : topsize;
-         op     : tasmop;
-      begin
-         oldtruelabel:=truelabel;
-         oldfalselabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         secondpass(pfrom);
-         { byte(boolean) or word(wordbool) or longint(longbool) must
-         be accepted for var parameters }
-         if (pto^.explizit) and
-            (pfrom^.resulttype^.size=pto^.resulttype^.size) and
-            (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-           begin
-              set_location(pto^.location,pfrom^.location);
-              truelabel:=oldtruelabel;
-              falselabel:=oldfalselabel;
-              exit;
-           end;
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         del_reference(pfrom^.location.reference);
-         case pfrom^.resulttype^.size of
-          1 : begin
-                case pto^.resulttype^.size of
-                 1 : opsize:=S_B;
-                 2 : opsize:=S_BW;
-                 4 : opsize:=S_BL;
-                end;
-              end;
-          2 : begin
-                case pto^.resulttype^.size of
-                 1 : begin
-                       if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-                        pfrom^.location.register:=reg16toreg8(pfrom^.location.register);
-                       opsize:=S_B;
-                     end;
-                 2 : opsize:=S_W;
-                 4 : opsize:=S_WL;
-                end;
-              end;
-          4 : begin
-                case pto^.resulttype^.size of
-                 1 : begin
-                       if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-                        pfrom^.location.register:=reg32toreg8(pfrom^.location.register);
-                       opsize:=S_B;
-                     end;
-                 2 : begin
-                       if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-                        pfrom^.location.register:=reg32toreg16(pfrom^.location.register);
-                       opsize:=S_W;
-                     end;
-                 4 : opsize:=S_L;
-                end;
-              end;
-         end;
-         if opsize in [S_B,S_W,S_L] then
-          op:=A_MOV
-         else
-          if is_signed(pto^.resulttype) then
-           op:=A_MOVSX
-          else
-           op:=A_MOVZX;
-         hregister:=getregister32;
-         case pto^.resulttype^.size of
-          1 : begin
-                pto^.location.register:=reg32toreg8(hregister);
-                newsize:=S_B;
-              end;
-          2 : begin
-                pto^.location.register:=reg32toreg16(hregister);
-                newsize:=S_W;
-              end;
-          4 : begin
-                pto^.location.register:=hregister;
-                newsize:=S_L;
-              end;
-         else
-          internalerror(10060);
-         end;
-
-         case pfrom^.location.loc of
-            LOC_MEM,
-      LOC_REFERENCE : emit_ref_reg(op,opsize,
-                        newreference(pfrom^.location.reference),pto^.location.register);
-       LOC_REGISTER,
-      LOC_CREGISTER : begin
-                      { remove things like movb %al,%al }
-                        if pfrom^.location.register<>pto^.location.register then
-                          emit_reg_reg(op,opsize,
-                            pfrom^.location.register,pto^.location.register);
-                      end;
-          LOC_FLAGS : begin
-                        emit_flag2reg(pfrom^.location.resflags,pto^.location.register);
-                      end;
-           LOC_JUMP : begin
-                        getlabel(hlabel);
-                        emitlab(truelabel);
-                        emit_const_reg(A_MOV,newsize,1,pto^.location.register);
-                        emitjmp(C_None,hlabel);
-                        emitlab(falselabel);
-                        emit_reg_reg(A_XOR,newsize,pto^.location.register,
-                          pto^.location.register);
-                        emitlab(hlabel);
-                      end;
-         else
-           internalerror(10061);
-         end;
-         truelabel:=oldtruelabel;
-         falselabel:=oldfalselabel;
-      end;
-
-
-    procedure second_int_to_bool(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        hregister : tregister;
-        flags     : tresflags;
-        opsize    : topsize;
-      begin
-         clear_location(pto^.location);
-         { byte(boolean) or word(wordbool) or longint(longbool) must
-         be accepted for var parameters }
-         if (pto^.explizit) and
-            (pfrom^.resulttype^.size=pto^.resulttype^.size) and
-            (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-           begin
-              set_location(pto^.location,pfrom^.location);
-              exit;
-           end;
-         pto^.location.loc:=LOC_REGISTER;
-         del_reference(pfrom^.location.reference);
-         opsize:=def_opsize(pfrom^.resulttype);
-         case pfrom^.location.loc of
-            LOC_MEM,LOC_REFERENCE :
-              begin
-                hregister:=def_getreg(pfrom^.resulttype);
-                emit_ref_reg(A_MOV,opsize,
-                  newreference(pfrom^.location.reference),hregister);
-                emit_reg_reg(A_OR,opsize,hregister,hregister);
-                flags:=F_NE;
-              end;
-            LOC_FLAGS :
-              begin
-                hregister:=getregister32;
-                flags:=pfrom^.location.resflags;
-              end;
-            LOC_REGISTER,LOC_CREGISTER :
-              begin
-                hregister:=pfrom^.location.register;
-                emit_reg_reg(A_OR,opsize,hregister,hregister);
-                flags:=F_NE;
-              end;
-            else
-              internalerror(10062);
-         end;
-         case pto^.resulttype^.size of
-          1 : pto^.location.register:=makereg8(hregister);
-          2 : pto^.location.register:=makereg16(hregister);
-          4 : pto^.location.register:=makereg32(hregister);
-         else
-          internalerror(10064);
-         end;
-         emit_flag2reg(flags,pto^.location.register);
-      end;
-
-
-    procedure second_load_smallset(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        href : treference;
-        pushedregs : tpushed;
-      begin
-        href.symbol:=nil;
-        pushusedregisters(pushedregs,$ff);
-        gettempofsizereference(32,href);
-        emitpushreferenceaddr(pfrom^.location.reference);
-        emitpushreferenceaddr(href);
-        emitcall('FPC_SET_LOAD_SMALL');
-        maybe_loadesi;
-        popusedregisters(pushedregs);
-        clear_location(pto^.location);
-        pto^.location.loc:=LOC_MEM;
-        pto^.location.reference:=href;
-      end;
-
-
-    procedure second_ansistring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-         l1 : pasmlabel;
-         hr : preference;
-      begin
-         clear_location(pto^.location);
-         pto^.location.loc:=LOC_REGISTER;
-         getlabel(l1);
-         case pfrom^.location.loc of
-            LOC_CREGISTER,LOC_REGISTER:
-              pto^.location.register:=pfrom^.location.register;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                pto^.location.register:=getregister32;
-                emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference),
-                  pto^.location.register);
-                del_reference(pfrom^.location.reference);
-              end;
-         end;
-         emit_const_reg(A_CMP,S_L,0,pto^.location.register);
-         emitjmp(C_NZ,l1);
-         new(hr);
-         reset_reference(hr^);
-         hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
-         emit_ref_reg(A_LEA,S_L,hr,pto^.location.register);
-         emitlab(l1);
-      end;
-
-
-    procedure second_pchar_to_string(var pto,pfrom : ptree;convtyp : tconverttype);
-      var
-        pushed : tpushed;
-        regs_to_push: byte;
-      begin
-         case pstringdef(pto^.resulttype)^.string_typ of
-           st_shortstring:
-             begin
-                pto^.location.loc:=LOC_REFERENCE;
-                gettempofsizereference(pto^.resulttype^.size,pto^.location.reference);
-                pushusedregisters(pushed,$ff);
-                case pfrom^.location.loc of
-                   LOC_REGISTER,LOC_CREGISTER:
-                     begin
-                        emit_reg(A_PUSH,S_L,pfrom^.location.register);
-                        ungetregister32(pfrom^.location.register);
-                     end;
-                   LOC_REFERENCE,LOC_MEM:
-                     begin
-                       { Now release the registers (see cgai386.pas:     }
-                       { loadansistring for more info on the order) (JM) }
-                        del_reference(pfrom^.location.reference);
-                        emit_push_mem(pfrom^.location.reference);
-                     end;
-                end;
-                emitpushreferenceaddr(pto^.location.reference);
-                emitcall('FPC_PCHAR_TO_SHORTSTR');
-                maybe_loadesi;
-                popusedregisters(pushed);
-             end;
-           st_ansistring:
-             begin
-                pto^.location.loc:=LOC_REFERENCE;
-                gettempansistringreference(pto^.location.reference);
-                decrstringref(cansistringdef,pto^.location.reference);
-                { Find out which regs have to be pushed (JM) }
-                regs_to_push := $ff;
-                remove_non_regvars_from_loc(pfrom^.location,regs_to_push);
-                pushusedregisters(pushed,regs_to_push);
-                case pfrom^.location.loc of
-                  LOC_REFERENCE,LOC_MEM:
-                    begin
-                      { Now release the registers (see cgai386.pas:     }
-                      { loadansistring for more info on the order) (JM) }
-                      del_reference(pfrom^.location.reference);
-                      emit_push_mem(pfrom^.location.reference);
-                    end;
-                  LOC_REGISTER,LOC_CREGISTER:
-                    begin
-                       { Now release the registers (see cgai386.pas:     }
-                       { loadansistring for more info on the order) (JM) }
-                      emit_reg(A_PUSH,S_L,pfrom^.location.register);
-                      ungetregister32(pfrom^.location.register);
-                   end;
-                end;
-                emitpushreferenceaddr(pto^.location.reference);
-                emitcall('FPC_PCHAR_TO_ANSISTR');
-                maybe_loadesi;
-                popusedregisters(pushed);
-             end;
-         else
-          begin
-            internalerror(12121);
-          end;
-         end;
-      end;
-
-
-    procedure second_nothing(var pto,pfrom : ptree;convtyp : tconverttype);
-      begin
-      end;
-
-
-{****************************************************************************
-                             SecondTypeConv
-****************************************************************************}
-
-    procedure secondtypeconv(var p : ptree);
-      const
-         secondconvert : array[tconverttype] of tsecondconvproc = (
-           second_nothing, {equal}
-           second_nothing, {not_possible}
-           second_string_to_string,
-           second_char_to_string,
-           second_pchar_to_string,
-           second_nothing, {cchar_to_pchar}
-           second_cstring_to_pchar,
-           second_ansistring_to_pchar,
-           second_string_to_chararray,
-           second_chararray_to_string,
-           second_array_to_pointer,
-           second_pointer_to_array,
-           second_int_to_int,
-           second_int_to_bool,
-           second_bool_to_int, { bool_to_bool }
-           second_bool_to_int,
-           second_real_to_real,
-           second_int_to_real,
-           second_int_to_fix,
-           second_real_to_fix,
-           second_fix_to_real,
-           second_proc_to_procvar,
-           second_nothing, {arrayconstructor_to_set}
-           second_load_smallset,
-           second_cord_to_pointer
-         );
-{$ifdef TESTOBJEXT2}
-      var
-         r : preference;
-         nillabel : plabel;
-{$endif TESTOBJEXT2}
-      begin
-
-         { this isn't good coding, I think tc_bool_2_int, shouldn't be }
-         { type conversion (FK)                                 }
-
-         if not(p^.convtyp in [tc_bool_2_int,tc_bool_2_bool]) then
-           begin
-              secondpass(p^.left);
-              set_location(p^.location,p^.left^.location);
-              if codegenerror then
-               exit;
-           end;
-         { the second argument only is for maybe_range_checking !}
-         secondconvert[p^.convtyp](p,p^.left,p^.convtyp);
-
-{$ifdef TESTOBJEXT2}
-                  { Check explicit conversions to objects pointers !! }
-                     if p^.explizit and
-                        (p^.resulttype^.deftype=pointerdef) and
-                        (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) and not
-                        (pobjectdef(ppointerdef(p^.resulttype)^.definition)^.isclass) and
-                        ((pobjectdef(ppointerdef(p^.resulttype)^.definition)^.options and oo_hasvmt)<>0) and
-                        (cs_check_range in aktlocalswitches) then
-                       begin
-                          new(r);
-                          reset_reference(r^);
-                          if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-                           r^.base:=p^.location.register
-                          else
-                            begin
-{$ifndef noAllocEdi}
-                               getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                               emit_mov_loc_reg(p^.location,R_EDI);
-                               r^.base:=R_EDI;
-                            end;
-                          { NIL must be accepted !! }
-                          emit_reg_reg(A_OR,S_L,r^.base,r^.base);
-{$ifndef noAllocEdi}
-                          ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                          getlabel(nillabel);
-                          emitjmp(C_E,nillabel);
-                          { this is one point where we need vmt_offset (PM) }
-                          r^.offset:= pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_offset;
-{$ifndef noAllocEdi}
-                          getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                          emit_ref_reg(A_MOV,S_L,r,R_EDI);
-                          emit_sym(A_PUSH,S_L,
-                            newasmsymbol(pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_mangledname));
-                          emit_reg(A_PUSH,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                          ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                          emitcall('FPC_CHECK_OBJECT_EXT');
-                          emitlab(nillabel);
-                       end;
-{$endif TESTOBJEXT2}
-      end;
-
-
-{*****************************************************************************
-                             SecondIs
-*****************************************************************************}
-
-    procedure secondis(var p : ptree);
-      var
-         pushed : tpushed;
-
-      begin
-         { save all used registers }
-         pushusedregisters(pushed,$ff);
-         secondpass(p^.left);
-         clear_location(p^.location);
-         p^.location.loc:=LOC_FLAGS;
-         p^.location.resflags:=F_NE;
-
-         { push instance to check: }
-         case p^.left^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 emit_reg(A_PUSH,
-                   S_L,p^.left^.location.register);
-                 ungetregister32(p^.left^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 emit_ref(A_PUSH,
-                   S_L,newreference(p^.left^.location.reference));
-                 del_reference(p^.left^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-
-         { generate type checking }
-         secondpass(p^.right);
-         case p^.right^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 emit_reg(A_PUSH,
-                   S_L,p^.right^.location.register);
-                 ungetregister32(p^.right^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 emit_ref(A_PUSH,
-                   S_L,newreference(p^.right^.location.reference));
-                 del_reference(p^.right^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-         emitcall('FPC_DO_IS');
-         emit_reg_reg(A_OR,S_B,R_AL,R_AL);
-         popusedregisters(pushed);
-         maybe_loadesi;
-      end;
-
-
-{*****************************************************************************
-                             SecondAs
-*****************************************************************************}
-
-    procedure secondas(var p : ptree);
-      var
-         pushed : tpushed;
-      begin
-         secondpass(p^.left);
-         { save all used registers }
-         pushusedregisters(pushed,$ff);
-
-         { push instance to check: }
-         case p^.left^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              emit_reg(A_PUSH,
-                S_L,p^.left^.location.register);
-            LOC_MEM,LOC_REFERENCE:
-              emit_ref(A_PUSH,
-                S_L,newreference(p^.left^.location.reference));
-            else internalerror(100);
-         end;
-
-         { we doesn't modifiy the left side, we check only the type }
-         set_location(p^.location,p^.left^.location);
-
-         { generate type checking }
-         secondpass(p^.right);
-         case p^.right^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 emit_reg(A_PUSH,
-                   S_L,p^.right^.location.register);
-                 ungetregister32(p^.right^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 emit_ref(A_PUSH,
-                   S_L,newreference(p^.right^.location.reference));
-                 del_reference(p^.right^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-         emitcall('FPC_DO_AS');
-         { restore register, this restores automatically the }
-         { result                                           }
-         popusedregisters(pushed);
-         maybe_loadesi;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.7  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.6  2000/08/29 18:31:32  peter
-    * string to chararray with stringconst only supports shortstring, don't
-      use the trick for ansistring (merged)
-
-  Revision 1.5  2000/08/09 11:30:21  jonas
-    * fixed bug1093 and other string -> chararray conversion bugs
-      (merged from fixes branch)
-
-  Revision 1.4  2000/08/02 07:05:32  jonas
-    * fixed ie(10) when using -Or and shortstring -> ansistring conversions
-      (or when using a lot of ss -> as conversions in one statement, the
-      source was freed only *after* pushusedregisters($ff), which means its
-      registers were reallocated when popusedregisters was called) (merged
-      from fixes branch)
-
-  Revision 1.3  2000/07/28 09:09:10  jonas
-    * fixed web bug1073 (merged from fixes branch)
-
-  Revision 1.2  2000/07/13 11:32:33  michael
-  + removed logs
-
-}

compiler/old/cg386con.pas

@@ -1,476 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for constants
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386con;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondrealconst(var p : ptree);
-    procedure secondfixconst(var p : ptree);
-    procedure secondordconst(var p : ptree);
-    procedure secondpointerconst(var p : ptree);
-    procedure secondstringconst(var p : ptree);
-    procedure secondsetconst(var p : ptree);
-    procedure secondniln(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386;
-
-{*****************************************************************************
-                             SecondRealConst
-*****************************************************************************}
-
-    procedure secondrealconst(var p : ptree);
-      const
-        floattype2ait:array[tfloattype] of tait=
-          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_none,ait_none);
-
-      var
-         hp1 : pai;
-         lastlabel : pasmlabel;
-         realait : tait;
-
-      begin
-         if (p^.value_real=1.0) then
-           begin
-              emit_none(A_FLD1,S_NO);
-              p^.location.loc:=LOC_FPU;
-              inc(fpuvaroffset);
-           end
-         else if (p^.value_real=0.0) then
-           begin
-              emit_none(A_FLDZ,S_NO);
-              p^.location.loc:=LOC_FPU;
-              inc(fpuvaroffset);
-           end
-         else
-           begin
-              lastlabel:=nil;
-              realait:=floattype2ait[pfloatdef(p^.resulttype)^.typ];
-              { const already used ? }
-              if not assigned(p^.lab_real) then
-                begin
-                   { tries to find an old entry }
-                   hp1:=pai(consts^.first);
-                   while assigned(hp1) do
-                     begin
-                        if hp1^.typ=ait_label then
-                          lastlabel:=pai_label(hp1)^.l
-                        else
-                          begin
-                             if (hp1^.typ=realait) and (lastlabel<>nil) then
-                               begin
-                                  if(
-                                     ((realait=ait_real_32bit) and (pai_real_32bit(hp1)^.value=p^.value_real)) or
-                                     ((realait=ait_real_64bit) and (pai_real_64bit(hp1)^.value=p^.value_real)) or
-                                     ((realait=ait_real_80bit) and (pai_real_80bit(hp1)^.value=p^.value_real)) or
-                                     ((realait=ait_comp_64bit) and (pai_comp_64bit(hp1)^.value=p^.value_real))
-                                    ) then
-                                    begin
-                                       { found! }
-                                       p^.lab_real:=lastlabel;
-                                       break;
-                                    end;
-                               end;
-                             lastlabel:=nil;
-                          end;
-                        hp1:=pai(hp1^.next);
-                     end;
-                   { :-(, we must generate a new entry }
-                   if not assigned(p^.lab_real) then
-                     begin
-                        getdatalabel(lastlabel);
-                        p^.lab_real:=lastlabel;
-                        if (cs_create_smart in aktmoduleswitches) then
-                         consts^.concat(new(pai_cut,init));
-                        consts^.concat(new(pai_label,init(lastlabel)));
-                        case realait of
-                          ait_real_32bit :
-                            consts^.concat(new(pai_real_32bit,init(p^.value_real)));
-                          ait_real_64bit :
-                            consts^.concat(new(pai_real_64bit,init(p^.value_real)));
-                          ait_real_80bit :
-                            consts^.concat(new(pai_real_80bit,init(p^.value_real)));
-                          ait_comp_64bit :
-                            consts^.concat(new(pai_comp_64bit,init(p^.value_real)));
-                        else
-                          internalerror(10120);
-                        end;
-                     end;
-                end;
-              reset_reference(p^.location.reference);
-              p^.location.reference.symbol:=p^.lab_real;
-              p^.location.loc:=LOC_MEM;
-           end;
-      end;
-
-
-{*****************************************************************************
-                             SecondFixConst
-*****************************************************************************}
-
-    procedure secondfixconst(var p : ptree);
-      begin
-         { an fix comma const. behaves as a memory reference }
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.is_immediate:=true;
-         p^.location.reference.offset:=p^.value_fix;
-      end;
-
-
-{*****************************************************************************
-                             SecondOrdConst
-*****************************************************************************}
-
-    procedure secondordconst(var p : ptree);
-
-      var
-         l : pasmlabel;
-
-      begin
-         p^.location.loc:=LOC_MEM;
-         if is_64bitint(p^.resulttype) then
-           begin
-              getdatalabel(l);
-              if (cs_create_smart in aktmoduleswitches) then
-                consts^.concat(new(pai_cut,init));
-              consts^.concat(new(pai_label,init(l)));
-              consts^.concat(new(pai_const,init_32bit(lo(p^.value))));
-              consts^.concat(new(pai_const,init_32bit(hi(p^.value))));
-              reset_reference(p^.location.reference);
-              p^.location.reference.symbol:=l;
-           end
-         else
-           begin
-              { non int64 const. behaves as a memory reference }
-              p^.location.reference.is_immediate:=true;
-              p^.location.reference.offset:=p^.value;
-           end;
-      end;
-
-
-{*****************************************************************************
-                             SecondPointerConst
-*****************************************************************************}
-
-    procedure secondpointerconst(var p : ptree);
-      begin
-         { an integer const. behaves as a memory reference }
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.is_immediate:=true;
-         p^.location.reference.offset:=p^.value;
-      end;
-
-
-{*****************************************************************************
-                             SecondStringConst
-*****************************************************************************}
-
-    procedure secondstringconst(var p : ptree);
-      var
-         hp1 : pai;
-         l1,l2,
-         lastlabel   : pasmlabel;
-         pc       : pchar;
-         same_string : boolean;
-         l,j,
-         i,mylength  : longint;
-      begin
-         { for empty ansistrings we could return a constant 0 }
-         if is_ansistring(p^.resulttype) and
-            (p^.length=0) then
-          begin
-            p^.location.loc:=LOC_MEM;
-            p^.location.reference.is_immediate:=true;
-            p^.location.reference.offset:=0;
-            exit;
-          end;
-         { const already used ? }
-         lastlabel:=nil;
-         if not assigned(p^.lab_str) then
-           begin
-              if is_shortstring(p^.resulttype) then
-               mylength:=p^.length+2
-              else
-               mylength:=p^.length+1;
-              { tries to found an old entry }
-              hp1:=pai(consts^.first);
-              while assigned(hp1) do
-                begin
-                   if hp1^.typ=ait_label then
-                     lastlabel:=pai_label(hp1)^.l
-                   else
-                     begin
-                        { when changing that code, be careful that }
-                        { you don't use typed consts, which are    }
-                        { are also written to consts           }
-                        { currently, this is no problem, because   }
-                        { typed consts have no leading length or   }
-                        { they have no trailing zero           }
-                        if (hp1^.typ=ait_string) and (lastlabel<>nil) and
-                           (pai_string(hp1)^.len=mylength) then
-                          begin
-                             same_string:=true;
-                             { if shortstring then check the length byte first and
-                               set the start index to 1 }
-                             if is_shortstring(p^.resulttype) then
-                              begin
-                                if p^.length<>ord(pai_string(hp1)^.str[0]) then
-                                 same_string:=false;
-                                j:=1;
-                              end
-                             else
-                              j:=0;
-                             { don't check if the length byte was already wrong }
-                             if same_string then
-                              begin
-                                for i:=0 to p^.length do
-                                 begin
-                                   if pai_string(hp1)^.str[j]<>p^.value_str[i] then
-                                    begin
-                                      same_string:=false;
-                                      break;
-                                    end;
-                                   inc(j);
-                                 end;
-                              end;
-                             { found ? }
-                             if same_string then
-                              begin
-                                p^.lab_str:=lastlabel;
-                                { create a new entry for ansistrings, but reuse the data }
-                                if (p^.stringtype in [st_ansistring,st_widestring]) then
-                                 begin
-                                   getdatalabel(l2);
-                                   consts^.concat(new(pai_label,init(l2)));
-                                   consts^.concat(new(pai_const_symbol,init(p^.lab_str)));
-                                   { return the offset of the real string }
-                                   p^.lab_str:=l2;
-                                 end;
-                                break;
-                              end;
-                          end;
-                        lastlabel:=nil;
-                     end;
-                   hp1:=pai(hp1^.next);
-                end;
-              { :-(, we must generate a new entry }
-              if not assigned(p^.lab_str) then
-                begin
-                   getdatalabel(lastlabel);
-                   p^.lab_str:=lastlabel;
-                   if (cs_create_smart in aktmoduleswitches) then
-                    consts^.concat(new(pai_cut,init));
-                   consts^.concat(new(pai_label,init(lastlabel)));
-                   { generate an ansi string ? }
-                   case p^.stringtype of
-                      st_ansistring:
-                        begin
-                           { an empty ansi string is nil! }
-                           if p^.length=0 then
-                             consts^.concat(new(pai_const,init_32bit(0)))
-                           else
-                             begin
-                                getdatalabel(l1);
-                                getdatalabel(l2);
-                                consts^.concat(new(pai_label,init(l2)));
-                                consts^.concat(new(pai_const_symbol,init(l1)));
-                                consts^.concat(new(pai_const,init_32bit(p^.length)));
-                                consts^.concat(new(pai_const,init_32bit(p^.length)));
-                                consts^.concat(new(pai_const,init_32bit(-1)));
-                                consts^.concat(new(pai_label,init(l1)));
-                                getmem(pc,p^.length+2);
-                                move(p^.value_str^,pc^,p^.length);
-                                pc[p^.length]:=#0;
-                                { to overcome this problem we set the length explicitly }
-                                { with the ending null char }
-                                consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1)));
-                                { return the offset of the real string }
-                                p^.lab_str:=l2;
-                             end;
-                        end;
-                      st_shortstring:
-                        begin
-                          { truncate strings larger than 255 chars }
-                          if p^.length>255 then
-                           l:=255
-                          else
-                           l:=p^.length;
-                          { also length and terminating zero }
-                          getmem(pc,l+3);
-                          move(p^.value_str^,pc[1],l+1);
-                          pc[0]:=chr(l);
-                          { to overcome this problem we set the length explicitly }
-                          { with the ending null char }
-                          pc[l+1]:=#0;
-                          consts^.concat(new(pai_string,init_length_pchar(pc,l+2)));
-                        end;
-                   end;
-                end;
-           end;
-         reset_reference(p^.location.reference);
-         p^.location.reference.symbol:=p^.lab_str;
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             SecondSetCons
-*****************************************************************************}
-
-    procedure secondsetconst(var p : ptree);
-      var
-         hp1     : pai;
-         lastlabel   : pasmlabel;
-         i         : longint;
-         neededtyp   : tait;
-      begin
-        { small sets are loaded as constants }
-        if psetdef(p^.resulttype)^.settype=smallset then
-         begin
-           p^.location.loc:=LOC_MEM;
-           p^.location.reference.is_immediate:=true;
-           p^.location.reference.offset:=plongint(p^.value_set)^;
-           exit;
-         end;
-        if psetdef(p^.resulttype)^.settype=smallset then
-         neededtyp:=ait_const_32bit
-        else
-         neededtyp:=ait_const_8bit;
-        lastlabel:=nil;
-        { const already used ? }
-        if not assigned(p^.lab_set) then
-          begin
-             { tries to found an old entry }
-             hp1:=pai(consts^.first);
-             while assigned(hp1) do
-               begin
-                  if hp1^.typ=ait_label then
-                    lastlabel:=pai_label(hp1)^.l
-                  else
-                    begin
-                      if (lastlabel<>nil) and (hp1^.typ=neededtyp) then
-                        begin
-                          if (hp1^.typ=ait_const_8bit) then
-                           begin
-                             { compare normal set }
-                             i:=0;
-                             while assigned(hp1) and (i<32) do
-                              begin
-                                if pai_const(hp1)^.value<>p^.value_set^[i] then
-                                 break;
-                                inc(i);
-                                hp1:=pai(hp1^.next);
-                              end;
-                             if i=32 then
-                              begin
-                                { found! }
-                                p^.lab_set:=lastlabel;
-                                break;
-                              end;
-                             { leave when the end of consts is reached, so no
-                               hp1^.next is done }
-                             if not assigned(hp1) then
-                              break;
-                           end
-                          else
-                           begin
-                             { compare small set }
-                             if plongint(p^.value_set)^=pai_const(hp1)^.value then
-                              begin
-                                { found! }
-                                p^.lab_set:=lastlabel;
-                                break;
-                              end;
-                           end;
-                        end;
-                      lastlabel:=nil;
-                    end;
-                  hp1:=pai(hp1^.next);
-               end;
-             { :-(, we must generate a new entry }
-             if not assigned(p^.lab_set) then
-               begin
-                 getdatalabel(lastlabel);
-                 p^.lab_set:=lastlabel;
-                 if (cs_create_smart in aktmoduleswitches) then
-                  consts^.concat(new(pai_cut,init));
-                 consts^.concat(new(pai_label,init(lastlabel)));
-                 if psetdef(p^.resulttype)^.settype=smallset then
-                  begin
-                    move(p^.value_set^,i,sizeof(longint));
-                    consts^.concat(new(pai_const,init_32bit(i)));
-                  end
-                 else
-                  begin
-                    for i:=0 to 31 do
-                      consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
-                  end;
-               end;
-          end;
-        reset_reference(p^.location.reference);
-        p^.location.reference.symbol:=p^.lab_set;
-        p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             SecondNilN
-*****************************************************************************}
-
-    procedure secondniln(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.is_immediate:=true;
-         p^.location.reference.offset:=0;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.4  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.3  2000/08/16 13:06:06  florian
-    + support of 64 bit integer constants
-
-  Revision 1.2  2000/07/13 11:32:33  michael
-  + removed logs
-
-}

compiler/old/cg386flw.pas

@@ -1,1259 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for nodes that influence the flow
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386flw;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure second_while_repeatn(var p : ptree);
-    procedure secondifn(var p : ptree);
-    procedure secondfor(var p : ptree);
-    procedure secondexitn(var p : ptree);
-    procedure secondbreakn(var p : ptree);
-    procedure secondcontinuen(var p : ptree);
-    procedure secondgoto(var p : ptree);
-    procedure secondlabel(var p : ptree);
-    procedure secondraise(var p : ptree);
-    procedure secondtryexcept(var p : ptree);
-    procedure secondtryfinally(var p : ptree);
-    procedure secondon(var p : ptree);
-    procedure secondfail(var p : ptree);
-
-    type
-       tenumflowcontrol = (fc_exit,fc_break,fc_continue);
-       tflowcontrol = set of tenumflowcontrol;
-
-    var
-       flowcontrol : tflowcontrol;
-
-implementation
-
-    uses
-      cobjects,verbose,globtype,globals,systems,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386,tcflw;
-
-{*****************************************************************************
-                         Second_While_RepeatN
-*****************************************************************************}
-
-    procedure second_while_repeatn(var p : ptree);
-      var
-         lcont,lbreak,lloop,
-         oldclabel,oldblabel : pasmlabel;
-         otlabel,oflabel : pasmlabel;
-
-      begin
-         getlabel(lloop);
-         getlabel(lcont);
-         getlabel(lbreak);
-         { arrange continue and breaklabels: }
-         oldclabel:=aktcontinuelabel;
-         oldblabel:=aktbreaklabel;
-
-         { handling code at the end as it is much more efficient, and makes
-           while equal to repeat loop, only the end true/false is swapped (PFV) }
-         if p^.treetype=whilen then
-          emitjmp(C_None,lcont);
-
-         emitlab(lloop);
-
-         aktcontinuelabel:=lcont;
-         aktbreaklabel:=lbreak;
-         cleartempgen;
-         if assigned(p^.right) then
-           secondpass(p^.right);
-         emitlab(lcont);
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         if p^.treetype=whilen then
-          begin
-            truelabel:=lloop;
-            falselabel:=lbreak;
-          end
-         { repeatn }
-         else
-          begin
-            truelabel:=lbreak;
-            falselabel:=lloop;
-          end;
-         cleartempgen;
-         secondpass(p^.left);
-         maketojumpbool(p^.left);
-         emitlab(lbreak);
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-
-         aktcontinuelabel:=oldclabel;
-         aktbreaklabel:=oldblabel;
-         { a break/continue in a while/repeat block can't be seen outside }
-         flowcontrol:=flowcontrol-[fc_break,fc_continue];
-      end;
-
-
-{*****************************************************************************
-                               SecondIfN
-*****************************************************************************}
-
-    procedure secondifn(var p : ptree);
-
-      var
-         hl,otlabel,oflabel : pasmlabel;
-
-      begin
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         cleartempgen;
-         secondpass(p^.left);
-         maketojumpbool(p^.left);
-         if assigned(p^.right) then
-           begin
-              emitlab(truelabel);
-              cleartempgen;
-              secondpass(p^.right);
-           end;
-         if assigned(p^.t1) then
-           begin
-              if assigned(p^.right) then
-                begin
-                   getlabel(hl);
-                   { do go back to if line !! }
-                   aktfilepos:=exprasmlist^.getlasttaifilepos^;
-                   emitjmp(C_None,hl);
-                end;
-              emitlab(falselabel);
-              cleartempgen;
-              secondpass(p^.t1);
-              if assigned(p^.right) then
-                emitlab(hl);
-           end
-         else
-           begin
-              emitlab(falselabel);
-           end;
-         if not(assigned(p^.right)) then
-           begin
-              emitlab(truelabel);
-           end;
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-      end;
-
-
-{*****************************************************************************
-                              SecondFor
-*****************************************************************************}
-
-    procedure secondfor(var p : ptree);
-      var
-         l3,oldclabel,oldblabel : pasmlabel;
-         omitfirstcomp,temptovalue : boolean;
-         hs : byte;
-         temp1 : treference;
-         hop : tasmop;
-         hcond : tasmcond;
-         cmpreg,cmp32 : tregister;
-         opsize : topsize;
-         count_var_is_signed : boolean;
-
-      begin
-         oldclabel:=aktcontinuelabel;
-         oldblabel:=aktbreaklabel;
-         getlabel(aktcontinuelabel);
-         getlabel(aktbreaklabel);
-         getlabel(l3);
-
-         { could we spare the first comparison ? }
-         omitfirstcomp:=false;
-         if p^.right^.treetype=ordconstn then
-           if p^.left^.right^.treetype=ordconstn then
-             omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value))
-               or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value));
-
-         { only calculate reference }
-         cleartempgen;
-         secondpass(p^.t2);
-         hs:=p^.t2^.resulttype^.size;
-         if p^.t2^.location.loc <> LOC_CREGISTER then
-           cmp32:=getregister32;
-         case hs of
-            1 : begin
-                   opsize:=S_B;
-                   if p^.t2^.location.loc <> LOC_CREGISTER then
-                     cmpreg:=reg32toreg8(cmp32);
-                end;
-            2 : begin
-                   opsize:=S_W;
-                   if p^.t2^.location.loc <> LOC_CREGISTER then
-                     cmpreg:=reg32toreg16(cmp32);
-                end;
-            4 : begin
-                   opsize:=S_L;
-                   if p^.t2^.location.loc <> LOC_CREGISTER then
-                     cmpreg:=cmp32;
-                end;
-         end;
-
-         { first set the to value
-           because the count var can be in the expression !! }
-         cleartempgen;
-         secondpass(p^.right);
-         { calculate pointer value and check if changeable and if so }
-         { load into temporary variable                       }
-         if p^.right^.treetype<>ordconstn then
-           begin
-              temp1.symbol:=nil;
-              gettempofsizereference(hs,temp1);
-              temptovalue:=true;
-              if (p^.right^.location.loc=LOC_REGISTER) or
-                 (p^.right^.location.loc=LOC_CREGISTER) then
-                begin
-                   emit_reg_ref(A_MOV,opsize,p^.right^.location.register,
-                      newreference(temp1));
-                 end
-              else
-                 concatcopy(p^.right^.location.reference,temp1,hs,false,false);
-           end
-         else
-           temptovalue:=false;
-
-         { produce start assignment }
-         cleartempgen;
-         secondpass(p^.left);
-         count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype));
-         if temptovalue then
-             begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-                begin
-                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
-                     p^.t2^.location.register);
-                end
-              else
-                begin
-                   emit_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
-                     cmpreg);
-                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
-                     cmpreg);
-                   { temp register not necessary anymore currently (JM) }
-                   ungetregister32(cmp32);
-                end;
-           end
-         else
-             begin
-              if not(omitfirstcomp) then
-                begin
-                   if p^.t2^.location.loc=LOC_CREGISTER then
-                     emit_const_reg(A_CMP,opsize,p^.right^.value,
-                       p^.t2^.location.register)
-                   else
-                     emit_const_ref(A_CMP,opsize,p^.right^.value,
-                       newreference(p^.t2^.location.reference));
-                end;
-           end;
-         if p^.backward then
-           if count_var_is_signed then
-             hcond:=C_L
-           else
-             hcond:=C_B
-         else
-           if count_var_is_signed then
-             hcond:=C_G
-           else
-             hcond:=C_A;
-
-         if not(omitfirstcomp) or temptovalue then
-           emitjmp(hcond,aktbreaklabel);
-
-         { align loop target }
-         if not(cs_littlesize in aktglobalswitches) then
-           exprasmlist^.concat(new(pai_align,init_op(4,$90)));
-
-         emitlab(l3);
-
-         { help register must not be in instruction block }
-         cleartempgen;
-         if assigned(p^.t1) then
-           secondpass(p^.t1);
-
-         emitlab(aktcontinuelabel);
-
-         { makes no problems there }
-         cleartempgen;
-
-         if (p^.t2^.location.loc <> LOC_CREGISTER) then
-           begin
-             { demand help register again }
-             cmp32:=getregister32;
-             case hs of
-                1 : cmpreg:=reg32toreg8(cmp32);
-                2 : cmpreg:=reg32toreg16(cmp32);
-                4 : cmpreg:=cmp32;
-             end;
-           end;
-
-         { produce comparison and the corresponding }
-         { jump                              }
-         if temptovalue then
-           begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-                begin
-                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
-                     p^.t2^.location.register);
-                end
-              else
-                begin
-                   emit_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
-                     cmpreg);
-                   emit_ref_reg(A_CMP,opsize,newreference(temp1),
-                     cmpreg);
-                    end;
-           end
-         else
-           begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-                emit_const_reg(A_CMP,opsize,p^.right^.value,
-                  p^.t2^.location.register)
-              else
-                 emit_const_ref(A_CMP,opsize,p^.right^.value,
-                   newreference(p^.t2^.location.reference));
-           end;
-         if p^.backward then
-           if count_var_is_signed then
-             hcond:=C_LE
-           else
-             hcond:=C_BE
-          else
-            if count_var_is_signed then
-              hcond:=C_GE
-            else
-              hcond:=C_AE;
-         emitjmp(hcond,aktbreaklabel);
-         { according to count direction DEC or INC... }
-         { must be after the test because of 0to 255 for bytes !! }
-         if p^.backward then
-           hop:=A_DEC
-         else
-           hop:=A_INC;
-
-         if p^.t2^.location.loc=LOC_CREGISTER then
-           emit_reg(hop,opsize,p^.t2^.location.register)
-         else
-           emit_ref(hop,opsize,newreference(p^.t2^.location.reference));
-         emitjmp(C_None,l3);
-
-         if (p^.t2^.location.loc <> LOC_CREGISTER) then
-           ungetregister32(cmp32);
-         if temptovalue then
-           ungetiftemp(temp1);
-
-         { this is the break label: }
-         emitlab(aktbreaklabel);
-
-         aktcontinuelabel:=oldclabel;
-         aktbreaklabel:=oldblabel;
-         { a break/continue in a for block can't be seen outside }
-         flowcontrol:=flowcontrol-[fc_break,fc_continue];
-      end;
-
-
-{*****************************************************************************
-                              SecondExitN
-*****************************************************************************}
-
-    procedure secondexitn(var p : ptree);
-      var
-         is_mem : boolean;
-         {op : tasmop;
-         s : topsize;}
-         otlabel,oflabel : pasmlabel;
-         r : preference;
-
-      label
-         do_jmp;
-      begin
-         include(flowcontrol,fc_exit);
-         if assigned(p^.left) then
-         if p^.left^.treetype=assignn then
-           begin
-              { just do a normal assignment followed by exit }
-              secondpass(p^.left);
-              emitjmp(C_None,aktexitlabel);
-           end
-         else
-           begin
-              otlabel:=truelabel;
-              oflabel:=falselabel;
-              getlabel(truelabel);
-              getlabel(falselabel);
-              secondpass(p^.left);
-              case p^.left^.location.loc of
-                 LOC_FPU : goto do_jmp;
-                 LOC_MEM,
-           LOC_REFERENCE : is_mem:=true;
-           LOC_CREGISTER,
-            LOC_REGISTER : is_mem:=false;
-               LOC_FLAGS : begin
-                             emit_flag2reg(p^.left^.location.resflags,R_AL);
-                             goto do_jmp;
-                           end;
-                LOC_JUMP : begin
-                             emitlab(truelabel);
-                             emit_const_reg(A_MOV,S_B,1,R_AL);
-                             emitjmp(C_None,aktexit2label);
-                             emitlab(falselabel);
-                             emit_reg_reg(A_XOR,S_B,R_AL,R_AL);
-                             goto do_jmp;
-                           end;
-              else
-                internalerror(2001);
-              end;
-              case procinfo^.returntype.def^.deftype of
-           pointerdef,
-           procvardef : begin
-                          if is_mem then
-                            emit_ref_reg(A_MOV,S_L,
-                              newreference(p^.left^.location.reference),R_EAX)
-                          else
-                            emit_reg_reg(A_MOV,S_L,
-                              p^.left^.location.register,R_EAX);
-                        end;
-             floatdef : begin
-                          if pfloatdef(procinfo^.returntype.def)^.typ=f32bit then
-                           begin
-                             if is_mem then
-                               emit_ref_reg(A_MOV,S_L,
-                                 newreference(p^.left^.location.reference),R_EAX)
-                             else
-                               emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX);
-                           end
-                          else
-                           if is_mem then
-                            floatload(pfloatdef(procinfo^.returntype.def)^.typ,p^.left^.location.reference);
-                        end;
-              { orddef,
-              enumdef : }
-              else
-              { it can be anything shorter than 4 bytes PM
-              this caused form bug 711 }
-                       begin
-                          case procinfo^.returntype.def^.size of
-                           { it can be a qword/int64 too ... }
-                           8 : if is_mem then
-                                 begin
-                                    emit_ref_reg(A_MOV,S_L,
-                                      newreference(p^.left^.location.reference),R_EAX);
-                                    r:=newreference(p^.left^.location.reference);
-                                    inc(r^.offset,4);
-                                    emit_ref_reg(A_MOV,S_L,r,R_EDX);
-                                 end
-                               else
-                                 begin
-                                    emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,R_EAX);
-                                    emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,R_EDX);
-                                 end;
-                          { if its 3 bytes only we can still
-                            copy one of garbage ! PM }
-                           4,3 : if is_mem then
-                                 emit_ref_reg(A_MOV,S_L,
-                                   newreference(p^.left^.location.reference),R_EAX)
-                               else
-                                 emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX);
-                           2 : if is_mem then
-                                 emit_ref_reg(A_MOV,S_W,
-                                   newreference(p^.left^.location.reference),R_AX)
-                               else
-                                 emit_reg_reg(A_MOV,S_W,makereg16(p^.left^.location.register),R_AX);
-                           1 : if is_mem then
-                                 emit_ref_reg(A_MOV,S_B,
-                                   newreference(p^.left^.location.reference),R_AL)
-                               else
-                                 emit_reg_reg(A_MOV,S_B,makereg8(p^.left^.location.register),R_AL);
-                           else internalerror(605001);
-                          end;
-                        end;
-              end;
-do_jmp:
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-              emitjmp(C_None,aktexit2label);
-           end
-         else
-           begin
-              emitjmp(C_None,aktexitlabel);
-           end;
-       end;
-
-
-{*****************************************************************************
-                              SecondBreakN
-*****************************************************************************}
-
-    procedure secondbreakn(var p : ptree);
-      begin
-         include(flowcontrol,fc_break);
-         if aktbreaklabel<>nil then
-           emitjmp(C_None,aktbreaklabel)
-         else
-           CGMessage(cg_e_break_not_allowed);
-      end;
-
-
-{*****************************************************************************
-                              SecondContinueN
-*****************************************************************************}
-
-    procedure secondcontinuen(var p : ptree);
-      begin
-         include(flowcontrol,fc_continue);
-         if aktcontinuelabel<>nil then
-           emitjmp(C_None,aktcontinuelabel)
-         else
-           CGMessage(cg_e_continue_not_allowed);
-      end;
-
-
-{*****************************************************************************
-                             SecondGoto
-*****************************************************************************}
-
-    procedure secondgoto(var p : ptree);
-
-       begin
-         emitjmp(C_None,p^.labelnr);
-         { the assigned avoids only crashes if the label isn't defined }
-         if assigned(p^.labsym) and
-           assigned(p^.labsym^.code) and
-            (aktexceptblock<>ptree(p^.labsym^.code)^.exceptionblock) then
-           CGMessage(cg_e_goto_inout_of_exception_block);
-       end;
-
-
-{*****************************************************************************
-                             SecondLabel
-*****************************************************************************}
-
-    procedure secondlabel(var p : ptree);
-      begin
-         emitlab(p^.labelnr);
-         cleartempgen;
-         secondpass(p^.left);
-      end;
-
-
-{*****************************************************************************
-                             SecondRaise
-*****************************************************************************}
-
-    procedure secondraise(var p : ptree);
-
-      var
-         a : pasmlabel;
-      begin
-         if assigned(p^.left) then
-           begin
-              { multiple parameters? }
-              if assigned(p^.right) then
-                begin
-                  { push frame }
-                  if assigned(p^.frametree) then
-                    begin
-                      secondpass(p^.frametree);
-                      if codegenerror then
-                       exit;
-                      emit_push_loc(p^.frametree^.location);
-                    end
-                  else
-                    emit_const(A_PUSH,S_L,0);
-                  { push address }
-                  secondpass(p^.right);
-                  if codegenerror then
-                   exit;
-                  emit_push_loc(p^.right^.location);
-                end
-              else
-                begin
-                   getaddrlabel(a);
-                   emitlab(a);
-                   emit_reg(A_PUSH,S_L,R_EBP);
-                   emit_sym(A_PUSH,S_L,a);
-                end;
-              { push object }
-              secondpass(p^.left);
-              if codegenerror then
-                exit;
-              emit_push_loc(p^.left^.location);
-              emitcall('FPC_RAISEEXCEPTION');
-           end
-         else
-           begin
-              emitcall('FPC_POPADDRSTACK');
-              emitcall('FPC_RERAISE');
-           end;
-       end;
-
-
-{*****************************************************************************
-                             SecondTryExcept
-*****************************************************************************}
-
-    var
-       endexceptlabel : pasmlabel;
-
-    { does the necessary things to clean up the object stack }
-    { in the except block                                    }
-    procedure cleanupobjectstack;
-
-      begin
-         emitcall('FPC_POPOBJECTSTACK');
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_DESTROYEXCEPTION');
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         maybe_loadesi;
-      end;
-
-    { pops one element from the exception address stack }
-    { and removes the flag                              }
-    procedure cleanupaddrstack;
-
-      begin
-         emitcall('FPC_POPADDRSTACK');
-         { allocate eax }
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_POP,S_L,R_EAX);
-         { deallocate eax }
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-      end;
-
-    procedure secondtryexcept(var p : ptree);
-
-      var
-         exceptlabel,doexceptlabel,oldendexceptlabel,
-         lastonlabel,
-         exitexceptlabel,
-         continueexceptlabel,
-         breakexceptlabel,
-         exittrylabel,
-         continuetrylabel,
-         breaktrylabel,
-         doobjectdestroy,
-         doobjectdestroyandreraise,
-         oldaktexitlabel,
-         oldaktexit2label,
-         oldaktcontinuelabel,
-         oldaktbreaklabel : pasmlabel;
-         oldexceptblock : ptree;
-
-
-         oldflowcontrol,tryflowcontrol,
-         exceptflowcontrol : tflowcontrol;
-      label
-         errorexit;
-      begin
-         oldflowcontrol:=flowcontrol;
-         flowcontrol:=[];
-         { this can be called recursivly }
-         oldendexceptlabel:=endexceptlabel;
-
-         { we modify EAX }
-         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
-
-         { save the old labels for control flow statements }
-         oldaktexitlabel:=aktexitlabel;
-         oldaktexit2label:=aktexit2label;
-         if assigned(aktbreaklabel) then
-           begin
-              oldaktcontinuelabel:=aktcontinuelabel;
-              oldaktbreaklabel:=aktbreaklabel;
-           end;
-
-         { get new labels for the control flow statements }
-         getlabel(exittrylabel);
-         getlabel(exitexceptlabel);
-         if assigned(aktbreaklabel) then
-           begin
-              getlabel(breaktrylabel);
-              getlabel(continuetrylabel);
-              getlabel(breakexceptlabel);
-              getlabel(continueexceptlabel);
-           end;
-
-         getlabel(exceptlabel);
-         getlabel(doexceptlabel);
-         getlabel(endexceptlabel);
-         getlabel(lastonlabel);
-         push_int (1); { push type of exceptionframe }
-         emitcall('FPC_PUSHEXCEPTADDR');
-         { allocate eax }
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_SETJMP');
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
-         { deallocate eax }
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitjmp(C_NE,exceptlabel);
-
-         { try block }
-         { set control flow labels for the try block }
-         aktexitlabel:=exittrylabel;
-         aktexit2label:=exittrylabel;
-         if assigned(oldaktbreaklabel) then
-          begin
-            aktcontinuelabel:=continuetrylabel;
-            aktbreaklabel:=breaktrylabel;
-          end;
-
-         oldexceptblock:=aktexceptblock;
-         aktexceptblock:=p^.left;
-         flowcontrol:=[];
-         secondpass(p^.left);
-         tryflowcontrol:=flowcontrol;
-         aktexceptblock:=oldexceptblock;
-         if codegenerror then
-           goto errorexit;
-
-         emitlab(exceptlabel);
-         emitcall('FPC_POPADDRSTACK');
-
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_POP,S_L,R_EAX);
-         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-
-         emitjmp(C_E,endexceptlabel);
-         emitlab(doexceptlabel);
-
-         { set control flow labels for the except block }
-         { and the on statements                        }
-         aktexitlabel:=exitexceptlabel;
-         aktexit2label:=exitexceptlabel;
-         if assigned(oldaktbreaklabel) then
-          begin
-            aktcontinuelabel:=continueexceptlabel;
-            aktbreaklabel:=breakexceptlabel;
-          end;
-
-         flowcontrol:=[];
-         { on statements }
-         if assigned(p^.right) then
-           begin
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.right;
-              secondpass(p^.right);
-              aktexceptblock:=oldexceptblock;
-           end;
-
-         emitlab(lastonlabel);
-         { default handling except handling }
-         if assigned(p^.t1) then
-           begin
-              { FPC_CATCHES must be called with
-                'default handler' flag (=-1)
-              }
-              push_int (-1);
-              emitcall('FPC_CATCHES');
-              maybe_loadesi;
-
-              { the destruction of the exception object must be also }
-              { guarded by an exception frame                        }
-              getlabel(doobjectdestroy);
-              getlabel(doobjectdestroyandreraise);
-              exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1)));
-              emitcall('FPC_PUSHEXCEPTADDR');
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              exprasmlist^.concat(new(paicpu,
-                op_reg(A_PUSH,S_L,R_EAX)));
-              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-              emitcall('FPC_SETJMP');
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              exprasmlist^.concat(new(paicpu,
-                op_reg(A_PUSH,S_L,R_EAX)));
-              exprasmlist^.concat(new(paicpu,
-                op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-              emitjmp(C_NE,doobjectdestroyandreraise);
-
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.t1;
-              { here we don't have to reset flowcontrol           }
-              { the default and on flowcontrols are handled equal }
-              secondpass(p^.t1);
-              exceptflowcontrol:=flowcontrol;
-              aktexceptblock:=oldexceptblock;
-
-              emitlab(doobjectdestroyandreraise);
-              emitcall('FPC_POPADDRSTACK');
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              exprasmlist^.concat(new(paicpu,
-                op_reg(A_POP,S_L,R_EAX)));
-              exprasmlist^.concat(new(paicpu,
-                op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-              emitjmp(C_E,doobjectdestroy);
-              emitcall('FPC_POPSECONDOBJECTSTACK');
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              emit_reg(A_PUSH,S_L,R_EAX);
-              emitcall('FPC_DESTROYEXCEPTION');
-              exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-              { we don't need to restore esi here because reraise never }
-              { returns                                                 }
-              emitcall('FPC_RERAISE');
-
-              emitlab(doobjectdestroy);
-              cleanupobjectstack;
-              emitjmp(C_None,endexceptlabel);
-           end
-         else
-           begin
-              emitcall('FPC_RERAISE');
-              exceptflowcontrol:=flowcontrol;
-           end;
-
-         if fc_exit in exceptflowcontrol then
-           begin
-              { do some magic for exit in the try block }
-              emitlab(exitexceptlabel);
-              { we must also destroy the address frame which guards }
-              { exception object                                    }
-              cleanupaddrstack;
-              cleanupobjectstack;
-              emitjmp(C_None,oldaktexitlabel);
-           end;
-
-         if fc_break in exceptflowcontrol then
-           begin
-              emitlab(breakexceptlabel);
-              { we must also destroy the address frame which guards }
-              { exception object                                    }
-              cleanupaddrstack;
-              cleanupobjectstack;
-              emitjmp(C_None,oldaktbreaklabel);
-           end;
-
-         if fc_continue in exceptflowcontrol then
-           begin
-              emitlab(continueexceptlabel);
-              { we must also destroy the address frame which guards }
-              { exception object                                    }
-              cleanupaddrstack;
-              cleanupobjectstack;
-              emitjmp(C_None,oldaktcontinuelabel);
-           end;
-
-         if fc_exit in tryflowcontrol then
-           begin
-              { do some magic for exit in the try block }
-              emitlab(exittrylabel);
-              cleanupaddrstack;
-              emitjmp(C_None,oldaktexitlabel);
-           end;
-
-         if fc_break in tryflowcontrol then
-           begin
-              emitlab(breaktrylabel);
-              cleanupaddrstack;
-              emitjmp(C_None,oldaktbreaklabel);
-           end;
-
-         if fc_continue in tryflowcontrol then
-           begin
-              emitlab(continuetrylabel);
-              cleanupaddrstack;
-              emitjmp(C_None,oldaktcontinuelabel);
-           end;
-
-         emitlab(endexceptlabel);
-
-       errorexit:
-         { restore all saved labels }
-         endexceptlabel:=oldendexceptlabel;
-
-         { restore the control flow labels }
-         aktexitlabel:=oldaktexitlabel;
-         aktexit2label:=oldaktexit2label;
-         if assigned(oldaktbreaklabel) then
-          begin
-            aktcontinuelabel:=oldaktcontinuelabel;
-            aktbreaklabel:=oldaktbreaklabel;
-          end;
-
-         { return all used control flow statements }
-         flowcontrol:=oldflowcontrol+exceptflowcontrol+
-           tryflowcontrol;
-      end;
-
-    procedure secondon(var p : ptree);
-
-      var
-         nextonlabel,
-         exitonlabel,
-         continueonlabel,
-         breakonlabel,
-         oldaktexitlabel,
-         oldaktexit2label,
-         oldaktcontinuelabel,
-         doobjectdestroyandreraise,
-         doobjectdestroy,
-         oldaktbreaklabel : pasmlabel;
-         ref : treference;
-         oldexceptblock : ptree;
-         oldflowcontrol : tflowcontrol;
-
-      begin
-         oldflowcontrol:=flowcontrol;
-         flowcontrol:=[];
-         getlabel(nextonlabel);
-
-         { push the vmt }
-         emit_sym(A_PUSH,S_L,
-           newasmsymbol(p^.excepttype^.vmt_mangledname));
-         emitcall('FPC_CATCHES');
-         { allocate eax }
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
-         emitjmp(C_E,nextonlabel);
-         ref.symbol:=nil;
-         gettempofsizereference(4,ref);
-
-         { what a hack ! }
-         if assigned(p^.exceptsymtable) then
-           pvarsym(p^.exceptsymtable^.symindex^.first)^.address:=ref.offset;
-
-         emit_reg_ref(A_MOV,S_L,
-           R_EAX,newreference(ref));
-         { deallocate eax }
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-
-         { in the case that another exception is risen }
-         { we've to destroy the old one                }
-         getlabel(doobjectdestroyandreraise);
-         exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1)));
-         emitcall('FPC_PUSHEXCEPTADDR');
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitcall('FPC_SETJMP');
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitjmp(C_NE,doobjectdestroyandreraise);
-
-         if assigned(p^.right) then
-           begin
-              oldaktexitlabel:=aktexitlabel;
-              oldaktexit2label:=aktexit2label;
-              getlabel(exitonlabel);
-              aktexitlabel:=exitonlabel;
-              aktexit2label:=exitonlabel;
-              if assigned(aktbreaklabel) then
-               begin
-                 oldaktcontinuelabel:=aktcontinuelabel;
-                 oldaktbreaklabel:=aktbreaklabel;
-                 getlabel(breakonlabel);
-                 getlabel(continueonlabel);
-                 aktcontinuelabel:=continueonlabel;
-                 aktbreaklabel:=breakonlabel;
-               end;
-
-              { esi is destroyed by FPC_CATCHES }
-              maybe_loadesi;
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.right;
-              secondpass(p^.right);
-              aktexceptblock:=oldexceptblock;
-           end;
-         getlabel(doobjectdestroy);
-         emitlab(doobjectdestroyandreraise);
-         emitcall('FPC_POPADDRSTACK');
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_POP,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitjmp(C_E,doobjectdestroy);
-         emitcall('FPC_POPSECONDOBJECTSTACK');
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_DESTROYEXCEPTION');
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         { we don't need to restore esi here because reraise never }
-         { returns                                                 }
-         emitcall('FPC_RERAISE');
-
-         emitlab(doobjectdestroy);
-         cleanupobjectstack;
-         { clear some stuff }
-         ungetiftemp(ref);
-         emitjmp(C_None,endexceptlabel);
-
-         if assigned(p^.right) then
-           begin
-              { special handling for control flow instructions }
-              if fc_exit in flowcontrol then
-                begin
-                   { the address and object pop does secondtryexcept }
-                   emitlab(exitonlabel);
-                   emitjmp(C_None,oldaktexitlabel);
-                end;
-
-              if fc_break in flowcontrol then
-                begin
-                   { the address and object pop does secondtryexcept }
-                   emitlab(breakonlabel);
-                   emitjmp(C_None,oldaktbreaklabel);
-                end;
-
-              if fc_continue in flowcontrol then
-                begin
-                   { the address and object pop does secondtryexcept }
-                   emitlab(continueonlabel);
-                   emitjmp(C_None,oldaktcontinuelabel);
-                end;
-
-              aktexitlabel:=oldaktexitlabel;
-              aktexit2label:=oldaktexit2label;
-              if assigned(oldaktbreaklabel) then
-               begin
-                 aktcontinuelabel:=oldaktcontinuelabel;
-                 aktbreaklabel:=oldaktbreaklabel;
-               end;
-           end;
-
-         emitlab(nextonlabel);
-         flowcontrol:=oldflowcontrol+flowcontrol;
-         { next on node }
-         if assigned(p^.left) then
-           begin
-              cleartempgen;
-              secondpass(p^.left);
-           end;
-      end;
-
-{*****************************************************************************
-                             SecondTryFinally
-*****************************************************************************}
-
-    procedure secondtryfinally(var p : ptree);
-
-      var
-         reraiselabel,
-         finallylabel,
-         endfinallylabel,
-         exitfinallylabel,
-         continuefinallylabel,
-         breakfinallylabel,
-         oldaktexitlabel,
-         oldaktexit2label,
-         oldaktcontinuelabel,
-         oldaktbreaklabel : pasmlabel;
-         oldexceptblock : ptree;
-         oldflowcontrol,tryflowcontrol : tflowcontrol;
-         decconst : longint;
-
-      begin
-         { check if child nodes do a break/continue/exit }
-         oldflowcontrol:=flowcontrol;
-         flowcontrol:=[];
-         { we modify EAX }
-         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
-         getlabel(finallylabel);
-         getlabel(endfinallylabel);
-         getlabel(reraiselabel);
-
-         { the finally block must catch break, continue and exit }
-         { statements                                            }
-         oldaktexitlabel:=aktexitlabel;
-         oldaktexit2label:=aktexit2label;
-         getlabel(exitfinallylabel);
-         aktexitlabel:=exitfinallylabel;
-         aktexit2label:=exitfinallylabel;
-         if assigned(aktbreaklabel) then
-          begin
-            oldaktcontinuelabel:=aktcontinuelabel;
-            oldaktbreaklabel:=aktbreaklabel;
-            getlabel(breakfinallylabel);
-            getlabel(continuefinallylabel);
-            aktcontinuelabel:=continuefinallylabel;
-            aktbreaklabel:=breakfinallylabel;
-          end;
-
-         push_int(1); { Type of stack-frame must be pushed}
-         emitcall('FPC_PUSHEXCEPTADDR');
-         { allocate eax }
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emitcall('FPC_SETJMP');
-         emit_reg(A_PUSH,S_L,R_EAX);
-         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
-         { deallocate eax }
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitjmp(C_NE,finallylabel);
-
-         { try code }
-         if assigned(p^.left) then
-           begin
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.left;
-              secondpass(p^.left);
-              tryflowcontrol:=flowcontrol;
-              if codegenerror then
-                exit;
-              aktexceptblock:=oldexceptblock;
-           end;
-
-         emitlab(finallylabel);
-         emitcall('FPC_POPADDRSTACK');
-         { finally code }
-         oldexceptblock:=aktexceptblock;
-         aktexceptblock:=p^.right;
-         flowcontrol:=[];
-         secondpass(p^.right);
-         if flowcontrol<>[] then
-           CGMessage(cg_e_control_flow_outside_finally);
-         aktexceptblock:=oldexceptblock;
-         if codegenerror then
-           exit;
-         { allocate eax }
-         exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-         emit_reg(A_POP,S_L,R_EAX);
-         emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX);
-         emitjmp(C_E,endfinallylabel);
-         emit_reg(A_DEC,S_L,R_EAX);
-         emitjmp(C_Z,reraiselabel);
-         if fc_exit in tryflowcontrol then
-           begin
-              emit_reg(A_DEC,S_L,R_EAX);
-              emitjmp(C_Z,oldaktexitlabel);
-              decconst:=1;
-           end
-         else
-           decconst:=2;
-         if fc_break in tryflowcontrol then
-           begin
-              emit_const_reg(A_SUB,S_L,decconst,R_EAX);
-              emitjmp(C_Z,oldaktbreaklabel);
-              decconst:=1;
-           end
-         else
-           inc(decconst);
-         if fc_continue in tryflowcontrol then
-           begin
-              emit_const_reg(A_SUB,S_L,decconst,R_EAX);
-              emitjmp(C_Z,oldaktcontinuelabel);
-           end;
-         { deallocate eax }
-         exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-         emitlab(reraiselabel);
-         emitcall('FPC_RERAISE');
-         { do some magic for exit,break,continue in the try block }
-         if fc_exit in tryflowcontrol then
-           begin
-              emitlab(exitfinallylabel);
-              { allocate eax }
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              emit_reg(A_POP,S_L,R_EAX);
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              emit_const(A_PUSH,S_L,2);
-              emitjmp(C_NONE,finallylabel);
-           end;
-         if fc_break in tryflowcontrol then
-          begin
-             emitlab(breakfinallylabel);
-             { allocate eax }
-             exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-             emit_reg(A_POP,S_L,R_EAX);
-             { deallocate eax }
-             exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX)));
-             emit_const(A_PUSH,S_L,3);
-             emitjmp(C_NONE,finallylabel);
-           end;
-         if fc_continue in tryflowcontrol then
-           begin
-              emitlab(continuefinallylabel);
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              emit_reg(A_POP,S_L,R_EAX);
-              exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
-              emit_const(A_PUSH,S_L,4);
-              emitjmp(C_NONE,finallylabel);
-           end;
-
-         emitlab(endfinallylabel);
-
-         aktexitlabel:=oldaktexitlabel;
-         aktexit2label:=oldaktexit2label;
-         if assigned(aktbreaklabel) then
-          begin
-            aktcontinuelabel:=oldaktcontinuelabel;
-            aktbreaklabel:=oldaktbreaklabel;
-          end;
-         flowcontrol:=oldflowcontrol+tryflowcontrol;
-      end;
-
-
-{*****************************************************************************
-                             SecondFail
-*****************************************************************************}
-
-    procedure secondfail(var p : ptree);
-      begin
-        emitjmp(C_None,faillabel);
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.6  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.5  2000/08/29 18:41:02  peter
-    * push ebp instead of 0 for raise without address
-
-  Revision 1.4  2000/08/13 08:41:07  peter
-    * restore labels when error in except block (merged)
-
-  Revision 1.3  2000/07/21 15:14:02  jonas
-    + added is_addr field for labels, if they are only used for getting the address
-       (e.g. for io checks) and corresponding getaddrlabel() procedure
-
-  Revision 1.2  2000/07/13 11:32:33  michael
-  + removed logs
-
-}

compiler/old/cg386inl.pas

@@ -1,1574 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 inline nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386inl;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondinline(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,fmodule,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_1,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386,cg386cal;
-
-
-{*****************************************************************************
-                                Helpers
-*****************************************************************************}
-
-    { reverts the parameter list }
-    var nb_para : longint;
-
-    function reversparameter(p : ptree) : ptree;
-
-       var
-         hp1,hp2 : ptree;
-
-      begin
-         hp1:=nil;
-         nb_para := 0;
-         while assigned(p) do
-           begin
-              { pull out }
-              hp2:=p;
-              p:=p^.right;
-              inc(nb_para);
-              { pull in }
-              hp2^.right:=hp1;
-              hp1:=hp2;
-           end;
-         reversparameter:=hp1;
-       end;
-
-
-{*****************************************************************************
-                             SecondInLine
-*****************************************************************************}
-
-    procedure StoreDirectFuncResult(var dest:ptree);
-      var
-        hp : ptree;
-        hdef : porddef;
-        hreg : tregister;
-        hregister : tregister;
-        oldregisterdef : boolean;
-        op : tasmop;
-        opsize : topsize;
-
-      begin
-        { Get the accumulator first so it can't be used in the dest }
-        if (dest^.resulttype^.deftype=orddef) and
-          not(is_64bitint(dest^.resulttype)) then
-          hregister:=getexplicitregister32(accumulator);
-        { process dest }
-        SecondPass(dest);
-        if Codegenerror then
-         exit;
-        { store the value }
-        Case dest^.resulttype^.deftype of
-          floatdef:
-            if dest^.location.loc=LOC_CFPUREGISTER then
-              begin
-                 floatstoreops(pfloatdef(dest^.resulttype)^.typ,op,opsize);
-                 emit_reg(op,opsize,correct_fpuregister(dest^.location.register,fpuvaroffset+1));
-              end
-            else
-              begin
-                 inc(fpuvaroffset);
-                 floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference);
-                 { floatstore decrements the fpu var offset }
-                 { but in fact we didn't increment it       }
-              end;
-          orddef:
-            begin
-              if is_64bitint(dest^.resulttype) then
-                begin
-                   emit_movq_reg_loc(R_EDX,R_EAX,dest^.location);
-                end
-              else
-               begin
-                 Case dest^.resulttype^.size of
-                  1 : hreg:=regtoreg8(hregister);
-                  2 : hreg:=regtoreg16(hregister);
-                  4 : hreg:=hregister;
-                 End;
-                 emit_mov_reg_loc(hreg,dest^.location);
-                 If (cs_check_range in aktlocalswitches) and
-                    {no need to rangecheck longints or cardinals on 32bit processors}
-                    not((porddef(dest^.resulttype)^.typ = s32bit) and
-                        (porddef(dest^.resulttype)^.low = longint($80000000)) and
-                        (porddef(dest^.resulttype)^.high = $7fffffff)) and
-                    not((porddef(dest^.resulttype)^.typ = u32bit) and
-                        (porddef(dest^.resulttype)^.low = 0) and
-                        (porddef(dest^.resulttype)^.high = longint($ffffffff))) then
-                  Begin
-                    {do not register this temporary def}
-                    OldRegisterDef := RegisterDef;
-                    RegisterDef := False;
-                    hdef:=nil;
-                    Case PordDef(dest^.resulttype)^.typ of
-                      u8bit,u16bit,u32bit:
-                        begin
-                          new(hdef,init(u32bit,0,$ffffffff));
-                          hreg:=hregister;
-                        end;
-                      s8bit,s16bit,s32bit:
-                        begin
-                          new(hdef,init(s32bit,$80000000,$7fffffff));
-                          hreg:=hregister;
-                        end;
-                    end;
-                    { create a fake node }
-                    hp := genzeronode(nothingn);
-                    hp^.location.loc := LOC_REGISTER;
-                    hp^.location.register := hreg;
-                    if assigned(hdef) then
-                      hp^.resulttype:=hdef
-                    else
-                      hp^.resulttype:=dest^.resulttype;
-                    { emit the range check }
-                    emitrangecheck(hp,dest^.resulttype);
-                    hp^.right := nil;
-                    if assigned(hdef) then
-                      Dispose(hdef, Done);
-                    RegisterDef := OldRegisterDef;
-                    disposetree(hp);
-                  End;
-                 ungetregister(hregister);
-               end;
-            End;
-          else
-            internalerror(66766766);
-        end;
-        { free used registers }
-        del_locref(dest^.location);
-      end;
-
-
-    procedure secondinline(var p : ptree);
-       const
-         {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
-{        float_name: array[tfloattype] of string[8]=
-           ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); }
-         incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC);
-         addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
-       var
-         aktfile : treference;
-         ft : tfiletyp;
-         opsize : topsize;
-         op,
-         asmop : tasmop;
-         pushed : tpushed;
-         {inc/dec}
-         addconstant : boolean;
-         addvalue : longint;
-
-
-      procedure handlereadwrite(doread,doln : boolean);
-      { produces code for READ(LN) and WRITE(LN) }
-
-        procedure loadstream;
-          const
-            io:array[boolean] of string[7]=('_OUTPUT','_INPUT');
-          var
-            r : preference;
-          begin
-            new(r);
-            reset_reference(r^);
-            r^.symbol:=newasmsymbol(
-            'U_'+upper(target_info.system_unit)+io[doread]);
-{$ifndef noAllocEdi}
-            getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-            emit_ref_reg(A_LEA,S_L,r,R_EDI)
-          end;
-
-        const
-           rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
-        var
-           node,hp    : ptree;
-           typedtyp,
-           pararesult : pdef;
-           orgfloattype : tfloattype;
-           dummycoll  : tparaitem;
-           iolabel    : pasmlabel;
-           npara      : longint;
-           esireloaded : boolean;
-
-        begin
-           { here we don't use register calling conventions }
-           dummycoll.init;
-           dummycoll.register:=R_NO;
-           { I/O check }
-           if (cs_check_io in aktlocalswitches) and
-              not(po_iocheck in aktprocsym^.definition^.procoptions) then
-             begin
-                getaddrlabel(iolabel);
-                emitlab(iolabel);
-             end
-           else
-             iolabel:=nil;
-           { for write of real with the length specified }
-           hp:=nil;
-           { reserve temporary pointer to data variable }
-           aktfile.symbol:=nil;
-           gettempofsizereference(4,aktfile);
-           { first state text data }
-           ft:=ft_text;
-           { and state a parameter ? }
-           if p^.left=nil then
-             begin
-                { the following instructions are for "writeln;" }
-                loadstream;
-                { save @aktfile in temporary variable }
-                emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
-{$ifndef noAllocEdi}
-                ungetregister32(R_EDI);
-{$endif noAllocEdi}
-             end
-           else
-             begin
-                { revers paramters }
-                node:=reversparameter(p^.left);
-
-                p^.left := node;
-                npara := nb_para;
-                { calculate data variable }
-                { is first parameter a file type ? }
-                if node^.left^.resulttype^.deftype=filedef then
-                  begin
-                     ft:=pfiledef(node^.left^.resulttype)^.filetyp;
-                     if ft=ft_typed then
-                       typedtyp:=pfiledef(node^.left^.resulttype)^.typedfiletype.def;
-                     secondpass(node^.left);
-                     if codegenerror then
-                       exit;
-
-                     { save reference in temporary variables }
-                     if node^.left^.location.loc<>LOC_REFERENCE then
-                       begin
-                          CGMessage(cg_e_illegal_expression);
-                          exit;
-                       end;
-{$ifndef noAllocEdi}
-                     getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-
-                     emit_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI);
-                     del_reference(node^.left^.location.reference);
-                     { skip to the next parameter }
-                     node:=node^.right;
-                  end
-                else
-                  begin
-                  { load stdin/stdout stream }
-                     loadstream;
-                  end;
-
-                { save @aktfile in temporary variable }
-                emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
-{$ifndef noAllocEdi}
-                ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                if doread then
-                { parameter by READ gives call by reference }
-                  dummycoll.paratyp:=vs_var
-                { an WRITE Call by "Const" }
-                else
-                  dummycoll.paratyp:=vs_const;
-
-                { because of secondcallparan, which otherwise attaches }
-                if ft=ft_typed then
-                  { this is to avoid copy of simple const parameters }
-                  {dummycoll.data:=new(pformaldef,init)}
-                  dummycoll.paratype.setdef(cformaldef)
-                else
-                  { I think, this isn't a good solution (FK) }
-                  dummycoll.paratype.reset;
-
-                while assigned(node) do
-                  begin
-                     esireloaded:=false;
-                     pushusedregisters(pushed,$ff);
-                     hp:=node;
-                     node:=node^.right;
-                     hp^.right:=nil;
-                     if hp^.is_colon_para then
-                       CGMessage(parser_e_illegal_colon_qualifier);
-                     { when float is written then we need bestreal to be pushed
-                       convert here else we loose the old float type }
-                     if (not doread) and
-                        (ft<>ft_typed) and
-                        (hp^.left^.resulttype^.deftype=floatdef) then
-                      begin
-                        orgfloattype:=pfloatdef(hp^.left^.resulttype)^.typ;
-                        hp^.left:=gentypeconvnode(hp^.left,bestrealdef^);
-                        firstpass(hp^.left);
-                      end;
-                     { when read ord,floats are functions, so they need this
-                       parameter as their destination instead of being pushed }
-                     if doread and
-                        (ft<>ft_typed) and
-                        (hp^.resulttype^.deftype in [orddef,floatdef]) then
-                      begin
-                      end
-                     else
-                      begin
-                        if ft=ft_typed then
-                          never_copy_const_param:=true;
-                        { reset data type }
-                        dummycoll.paratype.reset;
-                        { create temporary defs for high tree generation }
-                        if doread and (is_shortstring(hp^.resulttype)) then
-                          dummycoll.paratype.setdef(openshortstringdef)
-                        else
-                          if (is_chararray(hp^.resulttype)) then
-                            dummycoll.paratype.setdef(openchararraydef);
-                        secondcallparan(hp,@dummycoll,false,false,false,0,0);
-                        if ft=ft_typed then
-                          never_copy_const_param:=false;
-                      end;
-                     hp^.right:=node;
-                     if codegenerror then
-                       exit;
-
-                     emit_push_mem(aktfile);
-                     if (ft=ft_typed) then
-                       begin
-                          { OK let's try this }
-                          { first we must only allow the right type }
-                          { we have to call blockread or blockwrite }
-                          { but the real problem is that            }
-                          { reset and rewrite should have set       }
-                          { the type size                          }
-                          { as recordsize for that file !!!!    }
-                          { how can we make that                    }
-                          { I think that is only possible by adding }
-                          { reset and rewrite to the inline list a call }
-                          { allways read only one record by element }
-                            push_int(typedtyp^.size);
-                            if doread then
-                              emitcall('FPC_TYPED_READ')
-                            else
-                              emitcall('FPC_TYPED_WRITE');
-                       end
-                     else
-                       begin
-                          { save current position }
-                          pararesult:=hp^.left^.resulttype;
-                          { handle possible field width  }
-                          { of course only for write(ln) }
-                          if not doread then
-                            begin
-                               { handle total width parameter }
-                              if assigned(node) and node^.is_colon_para then
-                                begin
-                                   hp:=node;
-                                   node:=node^.right;
-                                   hp^.right:=nil;
-                                   dummycoll.paratype.setdef(hp^.resulttype);
-                                   dummycoll.paratyp:=vs_value;
-                                   secondcallparan(hp,@dummycoll,false,false,false,0,0);
-                                   hp^.right:=node;
-                                   if codegenerror then
-                                     exit;
-                                end
-                              else
-                                if pararesult^.deftype<>floatdef then
-                                  push_int(0)
-                                else
-                                  push_int(-32767);
-                            { a second colon para for a float ? }
-                              if assigned(node) and node^.is_colon_para then
-                                begin
-                                   hp:=node;
-                                   node:=node^.right;
-                                   hp^.right:=nil;
-                                   dummycoll.paratype.setdef(hp^.resulttype);
-                                   dummycoll.paratyp:=vs_value;
-                                   secondcallparan(hp,@dummycoll,false,false,false,0,0);
-                                   hp^.right:=node;
-                                   if pararesult^.deftype<>floatdef then
-                                     CGMessage(parser_e_illegal_colon_qualifier);
-                                   if codegenerror then
-                                     exit;
-                                end
-                              else
-                                begin
-                                  if pararesult^.deftype=floatdef then
-                                    push_int(-1);
-                                end;
-                             { push also the real type for floats }
-                              if pararesult^.deftype=floatdef then
-                                push_int(ord(orgfloattype));
-                            end;
-                          case pararesult^.deftype of
-                            stringdef :
-                              begin
-                                emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname);
-                              end;
-                            pointerdef :
-                              begin
-                                if is_pchar(pararesult) then
-                                  emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER')
-                              end;
-                            arraydef :
-                              begin
-                                if is_chararray(pararesult) then
-                                  emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY')
-                              end;
-                            floatdef :
-                              begin
-                                emitcall(rdwrprefix[doread]+'FLOAT');
-                                {
-                                if pfloatdef(p^.resulttype)^.typ<>f32bit then
-                                  dec(fpuvaroffset);
-                                }
-                                if doread then
-                                  begin
-                                     maybe_loadesi;
-                                     esireloaded:=true;
-                                     StoreDirectFuncResult(hp^.left);
-                                  end;
-                              end;
-                            orddef :
-                              begin
-                                case porddef(pararesult)^.typ of
-                                  s8bit,s16bit,s32bit :
-                                    emitcall(rdwrprefix[doread]+'SINT');
-                                  u8bit,u16bit,u32bit :
-                                    emitcall(rdwrprefix[doread]+'UINT');
-                                  uchar :
-                                    emitcall(rdwrprefix[doread]+'CHAR');
-                                  s64bit :
-                                    emitcall(rdwrprefix[doread]+'INT64');
-                                  u64bit :
-                                    emitcall(rdwrprefix[doread]+'QWORD');
-                                  bool8bit,
-                                  bool16bit,
-                                  bool32bit :
-                                    emitcall(rdwrprefix[doread]+'BOOLEAN');
-                                end;
-                                if doread then
-                                  begin
-                                     maybe_loadesi;
-                                     esireloaded:=true;
-                                     StoreDirectFuncResult(hp^.left);
-                                  end;
-                              end;
-                          end;
-                       end;
-                   { load ESI in methods again }
-                     popusedregisters(pushed);
-                     if not(esireloaded) then
-                       maybe_loadesi;
-                  end;
-             end;
-         { Insert end of writing for textfiles }
-           if ft=ft_text then
-             begin
-               pushusedregisters(pushed,$ff);
-               emit_push_mem(aktfile);
-               if doread then
-                begin
-                  if doln then
-                    emitcall('FPC_READLN_END')
-                  else
-                    emitcall('FPC_READ_END');
-                end
-               else
-                begin
-                  if doln then
-                    emitcall('FPC_WRITELN_END')
-                  else
-                    emitcall('FPC_WRITE_END');
-                end;
-               popusedregisters(pushed);
-               maybe_loadesi;
-             end;
-         { Insert IOCheck if set }
-           if assigned(iolabel) then
-             begin
-                { registers are saved in the procedure }
-                emit_sym(A_PUSH,S_L,iolabel);
-                emitcall('FPC_IOCHECK');
-             end;
-         { Freeup all used temps }
-           ungetiftemp(aktfile);
-           if assigned(p^.left) then
-             begin
-                p^.left:=reversparameter(p^.left);
-                if npara<>nb_para then
-                  CGMessage(cg_f_internal_error_in_secondinline);
-                hp:=p^.left;
-                while assigned(hp) do
-                  begin
-                     if assigned(hp^.left) then
-                       if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-                         ungetiftemp(hp^.left^.location.reference);
-                     hp:=hp^.right;
-                  end;
-             end;
-        end;
-
-      procedure handle_str;
-
-        var
-           hp,node : ptree;
-           dummycoll : tparaitem;
-           is_real : boolean;
-           realtype : tfloattype;
-           procedureprefix : string;
-
-          begin
-           dummycoll.init;
-           dummycoll.register:=R_NO;
-           pushusedregisters(pushed,$ff);
-           node:=p^.left;
-           is_real:=false;
-           while assigned(node^.right) do node:=node^.right;
-           { if a real parameter somewhere then call REALSTR }
-           if (node^.left^.resulttype^.deftype=floatdef) then
-            begin
-              is_real:=true;
-              realtype:=pfloatdef(node^.left^.resulttype)^.typ;
-            end;
-
-           node:=p^.left;
-           { we have at least two args }
-           { with at max 2 colon_para in between }
-
-           { string arg }
-           hp:=node;
-           node:=node^.right;
-           hp^.right:=nil;
-           dummycoll.paratyp:=vs_var;
-           if is_shortstring(hp^.resulttype) then
-             dummycoll.paratype.setdef(openshortstringdef)
-           else
-             dummycoll.paratype.setdef(hp^.resulttype);
-           procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_';
-           secondcallparan(hp,@dummycoll,false,false,false,0,0);
-           if codegenerror then
-             exit;
-
-           dummycoll.paratyp:=vs_const;
-           disposetree(p^.left);
-           p^.left:=nil;
-           { second arg }
-           hp:=node;
-           node:=node^.right;
-           hp^.right:=nil;
-
-           { if real push real type }
-           if is_real then
-             push_int(ord(realtype));
-
-           { frac  para }
-           if hp^.is_colon_para and assigned(node) and
-              node^.is_colon_para then
-             begin
-                dummycoll.paratype.setdef(hp^.resulttype);
-                dummycoll.paratyp:=vs_value;
-                secondcallparan(hp,@dummycoll,false,false,false,0,0);
-                if codegenerror then
-                  exit;
-                disposetree(hp);
-                hp:=node;
-                node:=node^.right;
-                hp^.right:=nil;
-             end
-           else
-             if is_real then
-             push_int(-1);
-
-           { third arg, length only if is_real }
-           if hp^.is_colon_para then
-             begin
-                dummycoll.paratype.setdef(hp^.resulttype);
-                dummycoll.paratyp:=vs_value;
-                secondcallparan(hp,@dummycoll,false,false,false,0,0);
-                if codegenerror then
-                  exit;
-                disposetree(hp);
-                hp:=node;
-                node:=node^.right;
-                hp^.right:=nil;
-             end
-           else
-             if is_real then
-               push_int(-32767)
-             else
-               push_int(-1);
-
-           { Convert float to bestreal }
-           if is_real then
-            begin
-              hp^.left:=gentypeconvnode(hp^.left,bestrealdef^);
-              firstpass(hp^.left);
-            end;
-
-           { last arg longint or real }
-           dummycoll.paratype.setdef(hp^.resulttype);
-           dummycoll.paratyp:=vs_value;
-           secondcallparan(hp,@dummycoll,false,false,false,0,0);
-           if codegenerror then
-             exit;
-
-           if is_real then
-             emitcall(procedureprefix+'FLOAT')
-           else
-             case porddef(hp^.resulttype)^.typ of
-                u32bit:
-                  emitcall(procedureprefix+'CARDINAL');
-
-                u64bit:
-                  emitcall(procedureprefix+'QWORD');
-
-                s64bit:
-                  emitcall(procedureprefix+'INT64');
-
-                else
-                  emitcall(procedureprefix+'LONGINT');
-             end;
-           disposetree(hp);
-
-           popusedregisters(pushed);
-        end;
-
-
-        Procedure Handle_Val;
-        var
-           hp,node, code_para, dest_para : ptree;
-           hreg,hreg2: TRegister;
-           hdef: POrdDef;
-           procedureprefix : string;
-           hr, hr2: TReference;
-           dummycoll : tparaitem;
-           has_code, has_32bit_code, oldregisterdef: boolean;
-           r : preference;
-
-          begin
-           dummycoll.init;
-           dummycoll.register:=R_NO;
-           node:=p^.left;
-           hp:=node;
-           node:=node^.right;
-           hp^.right:=nil;
-          {if we have 3 parameters, we have a code parameter}
-           has_code := Assigned(node^.right);
-           has_32bit_code := false;
-           reset_reference(hr);
-           hreg := R_NO;
-
-           If has_code then
-             Begin
-               {code is an orddef, that's checked in tcinl}
-               code_para := hp;
-               hp := node;
-               node := node^.right;
-               hp^.right := nil;
-               has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]);
-             End;
-
-          {hp = destination now, save for later use}
-           dest_para := hp;
-
-          {if EAX is already in use, it's a register variable. Since we don't
-           need another register besides EAX, release the one we got}
-           If hreg <> R_EAX Then ungetregister32(hreg);
-
-          {load and push the address of the destination}
-           dummycoll.paratyp:=vs_var;
-           dummycoll.paratype.setdef(dest_para^.resulttype);
-           secondcallparan(dest_para,@dummycoll,false,false,false,0,0);
-           if codegenerror then
-             exit;
-
-          {save the regvars}
-           pushusedregisters(pushed,$ff);
-
-          {now that we've already pushed the addres of dest_para^.left on the
-           stack, we can put the real parameters on the stack}
-
-           If has_32bit_code Then
-             Begin
-               dummycoll.paratyp:=vs_var;
-               dummycoll.paratype.setdef(code_para^.resulttype);
-               secondcallparan(code_para,@dummycoll,false,false,false,0,0);
-               if codegenerror then
-                 exit;
-               Disposetree(code_para);
-             End
-           Else
-             Begin
-           {only 32bit code parameter is supported, so fake one}
-               GetTempOfSizeReference(4,hr);
-               emitpushreferenceaddr(hr);
-             End;
-
-          {node = first parameter = string}
-           dummycoll.paratyp:=vs_const;
-           dummycoll.paratype.setdef(node^.resulttype);
-           secondcallparan(node,@dummycoll,false,false,false,0,0);
-           if codegenerror then
-             exit;
-
-           Case dest_para^.resulttype^.deftype of
-             floatdef:
-               begin
-                  procedureprefix := 'FPC_VAL_REAL_';
-                  if pfloatdef(p^.resulttype)^.typ<>f32bit then
-                    inc(fpuvaroffset);
-               end;
-             orddef:
-               if is_64bitint(dest_para^.resulttype) then
-                 begin
-                    if is_signed(dest_para^.resulttype) then
-                      procedureprefix := 'FPC_VAL_INT64_'
-                    else
-                      procedureprefix := 'FPC_VAL_QWORD_';
-                 end
-               else
-                 begin
-                    if is_signed(dest_para^.resulttype) then
-                      begin
-                        {if we are converting to a signed number, we have to include the
-                         size of the destination, so the Val function can extend the sign
-                         of the result to allow proper range checking}
-                        emit_const(A_PUSH,S_L,dest_para^.resulttype^.size);
-                        procedureprefix := 'FPC_VAL_SINT_'
-                      end
-                    else
-                      procedureprefix := 'FPC_VAL_UINT_';
-                 end;
-           End;
-           emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname);
-           { before disposing node we need to ungettemp !! PM }
-           if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then
-             ungetiftemp(node^.left^.location.reference);
-           disposetree(node);
-           p^.left := nil;
-
-          {reload esi in case the dest_para/code_para is a class variable or so}
-           maybe_loadesi;
-
-           If (dest_para^.resulttype^.deftype = orddef) Then
-             Begin
-              {store the result in a safe place, because EAX may be used by a
-               register variable}
-               hreg := getexplicitregister32(R_EAX);
-               emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
-               if is_64bitint(dest_para^.resulttype) then
-                 begin
-                    hreg2:=getexplicitregister32(R_EDX);
-                    emit_reg_reg(A_MOV,S_L,R_EDX,hreg2);
-                 end;
-              {as of now, hreg now holds the location of the result, if it was
-               integer}
-             End;
-
-           { restore the register vars}
-
-           popusedregisters(pushed);
-
-           If has_code and Not(has_32bit_code) Then
-             {only 16bit code is possible}
-             Begin
-              {load the address of the code parameter}
-               secondpass(code_para^.left);
-              {move the code to its destination}
-{$ifndef noAllocEdi}
-               getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-               emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI);
-               emit_mov_reg_loc(R_DI,code_para^.left^.location);
-{$ifndef noAllocEdi}
-               ungetregister32(R_EDI);
-{$endif noAllocEdi}
-               Disposetree(code_para);
-             End;
-
-          {restore the address of the result}
-{$ifndef noAllocEdi}
-           getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-           emit_reg(A_POP,S_L,R_EDI);
-
-          {set up hr2 to a refernce with EDI as base register}
-           reset_reference(hr2);
-           hr2.base := R_EDI;
-
-          {save the function result in the destination variable}
-           Case dest_para^.left^.resulttype^.deftype of
-             floatdef:
-               floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, hr2);
-             orddef:
-               Case PordDef(dest_para^.left^.resulttype)^.typ of
-                 u8bit,s8bit:
-                   emit_reg_ref(A_MOV, S_B,
-                     RegToReg8(hreg),newreference(hr2));
-                 u16bit,s16bit:
-                   emit_reg_ref(A_MOV, S_W,
-                     RegToReg16(hreg),newreference(hr2));
-                 u32bit,s32bit:
-                   emit_reg_ref(A_MOV, S_L,
-                     hreg,newreference(hr2));
-                 u64bit,s64bit:
-                   begin
-                      emit_reg_ref(A_MOV, S_L,
-                        hreg,newreference(hr2));
-                      r:=newreference(hr2);
-                      inc(r^.offset,4);
-                      emit_reg_ref(A_MOV, S_L,
-                        hreg2,r);
-                   end;
-               End;
-           End;
-{$ifndef noAllocEdi}
-           ungetregister32(R_EDI);
-{$endif noAllocEdi}
-           If (cs_check_range in aktlocalswitches) and
-              (dest_para^.left^.resulttype^.deftype = orddef) and
-              (not(is_64bitint(dest_para^.left^.resulttype))) and
-            {the following has to be changed to 64bit checking, once Val
-             returns 64 bit values (unless a special Val function is created
-             for that)}
-            {no need to rangecheck longints or cardinals on 32bit processors}
-               not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and
-                   (porddef(dest_para^.left^.resulttype)^.low = longint($80000000)) and
-                   (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and
-               not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and
-                   (porddef(dest_para^.left^.resulttype)^.low = 0) and
-                   (porddef(dest_para^.left^.resulttype)^.high = longint($ffffffff))) then
-             Begin
-               hp := getcopy(dest_para^.left);
-               hp^.location.loc := LOC_REGISTER;
-               hp^.location.register := hreg;
-              {do not register this temporary def}
-               OldRegisterDef := RegisterDef;
-               RegisterDef := False;
-               Case PordDef(dest_para^.left^.resulttype)^.typ of
-                 u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff));
-                 s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff));
-               end;
-               hp^.resulttype := hdef;
-               emitrangecheck(hp,dest_para^.left^.resulttype);
-               hp^.right := nil;
-               Dispose(hp^.resulttype, Done);
-               RegisterDef := OldRegisterDef;
-               disposetree(hp);
-             End;
-          {dest_para^.right is already nil}
-           disposetree(dest_para);
-           UnGetIfTemp(hr);
-        end;
-
-      var
-         r : preference;
-         hp : ptree;
-         l : longint;
-         ispushed : boolean;
-         hregister : tregister;
-         otlabel,oflabel{,l1}   : pasmlabel;
-         oldpushedparasize : longint;
-
-      begin
-      { save & reset pushedparasize }
-         oldpushedparasize:=pushedparasize;
-         pushedparasize:=0;
-         case p^.inlinenumber of
-            in_assert_x_y:
-              begin
-                 { the node should be removed in the firstpass }
-                 if not (cs_do_assertion in aktlocalswitches) then
-                  internalerror(7123458);
-                 otlabel:=truelabel;
-                 oflabel:=falselabel;
-                 getlabel(truelabel);
-                 getlabel(falselabel);
-                 secondpass(p^.left^.left);
-                 maketojumpbool(p^.left^.left);
-                 emitlab(falselabel);
-                 { erroraddr }
-                 emit_reg(A_PUSH,S_L,R_EBP);
-                 { lineno }
-                 emit_const(A_PUSH,S_L,aktfilepos.line);
-                 { filename string }
-                 hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex),st_shortstring);
-                 secondpass(hp);
-                 if codegenerror then
-                  exit;
-                 emitpushreferenceaddr(hp^.location.reference);
-                 disposetree(hp);
-                 { push msg }
-                 secondpass(p^.left^.right^.left);
-                 emitpushreferenceaddr(p^.left^.right^.left^.location.reference);
-                 { call }
-                 emitcall('FPC_ASSERT');
-                 emitlab(truelabel);
-                 truelabel:=otlabel;
-                 falselabel:=oflabel;
-              end;
-            in_lo_word,
-            in_hi_word :
-              begin
-                 secondpass(p^.left);
-                 p^.location.loc:=LOC_REGISTER;
-                 if p^.left^.location.loc<>LOC_REGISTER then
-                   begin
-                     if p^.left^.location.loc=LOC_CREGISTER then
-                       begin
-                          p^.location.register:=reg32toreg16(getregister32);
-                          emit_reg_reg(A_MOV,S_W,p^.left^.location.register,
-                            p^.location.register);
-                       end
-                     else
-                       begin
-                          del_reference(p^.left^.location.reference);
-                          p^.location.register:=reg32toreg16(getregister32);
-                          emit_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference),
-                            p^.location.register);
-                       end;
-                   end
-                 else p^.location.register:=p^.left^.location.register;
-                 if p^.inlinenumber=in_hi_word then
-                   emit_const_reg(A_SHR,S_W,8,p^.location.register);
-                 p^.location.register:=reg16toreg8(p^.location.register);
-              end;
-            in_sizeof_x,
-            in_typeof_x :
-              begin
-                 { for both cases load vmt }
-                 if p^.left^.treetype=typen then
-                   begin
-                      p^.location.register:=getregister32;
-                      emit_sym_ofs_reg(A_MOV,
-                        S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
-                        p^.location.register);
-                   end
-                 else
-                   begin
-                      secondpass(p^.left);
-                      del_reference(p^.left^.location.reference);
-                      p^.location.loc:=LOC_REGISTER;
-                      p^.location.register:=getregister32;
-                      { load VMT pointer }
-                      inc(p^.left^.location.reference.offset,
-                        pobjectdef(p^.left^.resulttype)^.vmt_offset);
-                      emit_ref_reg(A_MOV,S_L,
-                      newreference(p^.left^.location.reference),
-                        p^.location.register);
-                   end;
-                 { in sizeof load size }
-                 if p^.inlinenumber=in_sizeof_x then
-                   begin
-                      new(r);
-                      reset_reference(r^);
-                      r^.base:=p^.location.register;
-                      emit_ref_reg(A_MOV,S_L,r,
-                        p^.location.register);
-                   end;
-              end;
-            in_lo_long,
-            in_hi_long :
-              begin
-                 secondpass(p^.left);
-                 p^.location.loc:=LOC_REGISTER;
-                 if p^.left^.location.loc<>LOC_REGISTER then
-                   begin
-                      if p^.left^.location.loc=LOC_CREGISTER then
-                        begin
-                           p^.location.register:=getregister32;
-                           emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
-                             p^.location.register);
-                        end
-                      else
-                        begin
-                           del_reference(p^.left^.location.reference);
-                           p^.location.register:=getregister32;
-                           emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
-                             p^.location.register);
-                        end;
-                   end
-                 else p^.location.register:=p^.left^.location.register;
-                 if p^.inlinenumber=in_hi_long then
-                   emit_const_reg(A_SHR,S_L,16,p^.location.register);
-                 p^.location.register:=reg32toreg16(p^.location.register);
-              end;
-            in_lo_qword,
-            in_hi_qword:
-              begin
-                 secondpass(p^.left);
-                 p^.location.loc:=LOC_REGISTER;
-                 case p^.left^.location.loc of
-                    LOC_CREGISTER:
-                      begin
-                         p^.location.register:=getregister32;
-                         if p^.inlinenumber=in_hi_qword then
-                           emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,
-                             p^.location.register)
-                         else
-                           emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,
-                             p^.location.register)
-                      end;
-                    LOC_MEM,LOC_REFERENCE:
-                      begin
-                         del_reference(p^.left^.location.reference);
-                         p^.location.register:=getregister32;
-                         r:=newreference(p^.left^.location.reference);
-                         if p^.inlinenumber=in_hi_qword then
-                           inc(r^.offset,4);
-                         emit_ref_reg(A_MOV,S_L,
-                           r,p^.location.register);
-                      end;
-                    LOC_REGISTER:
-                      begin
-                         if p^.inlinenumber=in_hi_qword then
-                           begin
-                              p^.location.register:=p^.left^.location.registerhigh;
-                              ungetregister32(p^.left^.location.registerlow);
-                           end
-                         else
-                           begin
-                              p^.location.register:=p^.left^.location.registerlow;
-                              ungetregister32(p^.left^.location.registerhigh);
-                           end;
-                      end;
-                 end;
-              end;
-            in_length_string :
-              begin
-                 secondpass(p^.left);
-                 set_location(p^.location,p^.left^.location);
-                 { length in ansi strings is at offset -8 }
-                 if is_ansistring(p^.left^.resulttype) then
-                   dec(p^.location.reference.offset,8)
-                 { char is always 1, so make it a constant value }
-                 else if is_char(p^.left^.resulttype) then
-                   begin
-                     clear_location(p^.location);
-                     p^.location.loc:=LOC_MEM;
-                     p^.location.reference.is_immediate:=true;
-                     p^.location.reference.offset:=1;
-                   end;
-              end;
-            in_pred_x,
-            in_succ_x:
-              begin
-                 secondpass(p^.left);
-                 if not (cs_check_overflow in aktlocalswitches) then
-                   if p^.inlinenumber=in_pred_x then
-                     asmop:=A_DEC
-                   else
-                     asmop:=A_INC
-                 else
-                   if p^.inlinenumber=in_pred_x then
-                     asmop:=A_SUB
-                   else
-                     asmop:=A_ADD;
-                 case p^.resulttype^.size of
-                   8 : opsize:=S_L;
-                   4 : opsize:=S_L;
-                   2 : opsize:=S_W;
-                   1 : opsize:=S_B;
-                 else
-                   internalerror(10080);
-                 end;
-                 p^.location.loc:=LOC_REGISTER;
-                 if p^.resulttype^.size=8 then
-                   begin
-                      if p^.left^.location.loc<>LOC_REGISTER then
-                        begin
-                           if p^.left^.location.loc=LOC_CREGISTER then
-                             begin
-                                p^.location.registerlow:=getregister32;
-                                p^.location.registerhigh:=getregister32;
-                                emit_reg_reg(A_MOV,opsize,p^.left^.location.registerlow,
-                                  p^.location.registerlow);
-                                emit_reg_reg(A_MOV,opsize,p^.left^.location.registerhigh,
-                                  p^.location.registerhigh);
-                             end
-                           else
-                             begin
-                                del_reference(p^.left^.location.reference);
-                                p^.location.registerlow:=getregister32;
-                                p^.location.registerhigh:=getregister32;
-                                emit_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference),
-                                  p^.location.registerlow);
-                                r:=newreference(p^.left^.location.reference);
-                                inc(r^.offset,4);
-                                emit_ref_reg(A_MOV,opsize,r,
-                                  p^.location.registerhigh);
-                             end;
-                        end
-                      else
-                        begin
-                           p^.location.registerhigh:=p^.left^.location.registerhigh;
-                           p^.location.registerlow:=p^.left^.location.registerlow;
-                        end;
-                      if p^.inlinenumber=in_succ_x then
-                        begin
-                           emit_const_reg(A_ADD,opsize,1,
-                             p^.location.registerlow);
-                           emit_const_reg(A_ADC,opsize,0,
-                             p^.location.registerhigh);
-                        end
-                      else
-                        begin
-                           emit_const_reg(A_SUB,opsize,1,
-                             p^.location.registerlow);
-                           emit_const_reg(A_SBB,opsize,0,
-                             p^.location.registerhigh);
-                        end;
-                   end
-                 else
-                   begin
-                      if p^.left^.location.loc<>LOC_REGISTER then
-                        begin
-                           { first, we've to release the source location ... }
-                           if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then
-                             del_reference(p^.left^.location.reference);
-
-                           p^.location.register:=getregister32;
-                           if (p^.resulttype^.size=2) then
-                             p^.location.register:=reg32toreg16(p^.location.register);
-                           if (p^.resulttype^.size=1) then
-                             p^.location.register:=reg32toreg8(p^.location.register);
-                           if p^.left^.location.loc=LOC_CREGISTER then
-                             emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
-                               p^.location.register)
-                           else
-                           if p^.left^.location.loc=LOC_FLAGS then
-                             emit_flag2reg(p^.left^.location.resflags,p^.location.register)
-                           else
-                             emit_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference),
-                               p^.location.register);
-                        end
-                      else p^.location.register:=p^.left^.location.register;
-                      if not (cs_check_overflow in aktlocalswitches) then
-                        emit_reg(asmop,opsize,
-                        p^.location.register)
-                      else
-                        emit_const_reg(asmop,opsize,1,
-                        p^.location.register);
-                   end;
-                 emitoverflowcheck(p);
-                 emitrangecheck(p,p^.resulttype);
-              end;
-            in_dec_x,
-            in_inc_x :
-              begin
-              { set defaults }
-                addvalue:=1;
-                addconstant:=true;
-              { load first parameter, must be a reference }
-                secondpass(p^.left^.left);
-                case p^.left^.left^.resulttype^.deftype of
-                  orddef,
-                 enumdef : begin
-                             case p^.left^.left^.resulttype^.size of
-                              1 : opsize:=S_B;
-                              2 : opsize:=S_W;
-                              4 : opsize:=S_L;
-                              8 : opsize:=S_L;
-                             end;
-                           end;
-              pointerdef : begin
-                             opsize:=S_L;
-                             if porddef(ppointerdef(p^.left^.left^.resulttype)^.pointertype.def)=voiddef then
-                              addvalue:=1
-                             else
-                              addvalue:=ppointerdef(p^.left^.left^.resulttype)^.pointertype.def^.size;
-                           end;
-                else
-                 internalerror(10081);
-                end;
-              { second argument specified?, must be a s32bit in register }
-                if assigned(p^.left^.right) then
-                 begin
-                   ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left,false);
-                   secondpass(p^.left^.right^.left);
-                   if ispushed then
-                     restore(p^.left^.left,false);
-                 { when constant, just multiply the addvalue }
-                   if is_constintnode(p^.left^.right^.left) then
-                    addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left)
-                   else
-                    begin
-                      case p^.left^.right^.left^.location.loc of
-                   LOC_REGISTER,
-                  LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register;
-                        LOC_MEM,
-                  LOC_REFERENCE : begin
-                                    del_reference(p^.left^.right^.left^.location.reference);
-                                    hregister:=getregister32;
-                                    emit_ref_reg(A_MOV,S_L,
-                                      newreference(p^.left^.right^.left^.location.reference),hregister);
-                                  end;
-                       else
-                        internalerror(10082);
-                       end;
-                    { insert multiply with addvalue if its >1 }
-                      if addvalue>1 then
-                       emit_const_reg(A_IMUL,opsize,
-                         addvalue,hregister);
-                      addconstant:=false;
-                    end;
-                 end;
-              { write the add instruction }
-                if addconstant then
-                 begin
-                   if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then
-                     begin
-                        if p^.left^.left^.location.loc=LOC_CREGISTER then
-                          emit_reg(incdecop[p^.inlinenumber],opsize,
-                            p^.left^.left^.location.register)
-                        else
-                          emit_ref(incdecop[p^.inlinenumber],opsize,
-                            newreference(p^.left^.left^.location.reference))
-                     end
-                   else
-                     begin
-                        if p^.left^.left^.location.loc=LOC_CREGISTER then
-                          emit_const_reg(addsubop[p^.inlinenumber],opsize,
-                            addvalue,p^.left^.left^.location.register)
-                        else
-                          emit_const_ref(addsubop[p^.inlinenumber],opsize,
-                            addvalue,newreference(p^.left^.left^.location.reference));
-                     end
-                 end
-                else
-                 begin
-                    { BUG HERE : detected with nasm :
-                      hregister is allways 32 bit
-                      it should be converted to 16 or 8 bit depending on op_size  PM }
-                    { still not perfect :
-                      if hregister is already a 16 bit reg ?? PM }
-                    { makeregXX is the solution (FK) }
-                    case opsize of
-                      S_B : hregister:=makereg8(hregister);
-                      S_W : hregister:=makereg16(hregister);
-                    end;
-                    if p^.left^.left^.location.loc=LOC_CREGISTER then
-                      emit_reg_reg(addsubop[p^.inlinenumber],opsize,
-                        hregister,p^.left^.left^.location.register)
-                    else
-                      emit_reg_ref(addsubop[p^.inlinenumber],opsize,
-                        hregister,newreference(p^.left^.left^.location.reference));
-                    case opsize of
-                      S_B : hregister:=reg8toreg32(hregister);
-                      S_W : hregister:=reg16toreg32(hregister);
-                    end;
-                   ungetregister32(hregister);
-                 end;
-                emitoverflowcheck(p^.left^.left);
-                emitrangecheck(p^.left^.left,p^.left^.left^.resulttype);
-              end;
-            in_typeinfo_x:
-               begin
-                  p^.left^.left^.typenodetype^.generate_rtti;
-                  p^.location.register:=getregister32;
-                  new(r);
-                  reset_reference(r^);
-                  r^.symbol:=p^.left^.left^.typenodetype^.rtti_label;
-                  emit_ref_reg(A_MOV,S_L,r,p^.location.register);
-               end;
-            in_assigned_x :
-              begin
-                 secondpass(p^.left^.left);
-                 p^.location.loc:=LOC_FLAGS;
-                 if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                   begin
-                      emit_reg_reg(A_OR,S_L,
-                        p^.left^.left^.location.register,
-                        p^.left^.left^.location.register);
-                      ungetregister32(p^.left^.left^.location.register);
-                   end
-                 else
-                   begin
-                      emit_const_ref(A_CMP,S_L,0,
-                        newreference(p^.left^.left^.location.reference));
-                      del_reference(p^.left^.left^.location.reference);
-                   end;
-                 p^.location.resflags:=F_NE;
-              end;
-             in_reset_typedfile,in_rewrite_typedfile :
-               begin
-                  pushusedregisters(pushed,$ff);
-                  emit_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typedfiletype.def^.size);
-                  secondpass(p^.left);
-                  emitpushreferenceaddr(p^.left^.location.reference);
-                  if p^.inlinenumber=in_reset_typedfile then
-                    emitcall('FPC_RESET_TYPED')
-                  else
-                    emitcall('FPC_REWRITE_TYPED');
-                  popusedregisters(pushed);
-               end;
-            in_write_x :
-              handlereadwrite(false,false);
-            in_writeln_x :
-              handlereadwrite(false,true);
-            in_read_x :
-              handlereadwrite(true,false);
-            in_readln_x :
-              handlereadwrite(true,true);
-            in_str_x_string :
-              begin
-                 handle_str;
-                 maybe_loadesi;
-              end;
-            in_val_x :
-              Begin
-                handle_val;
-              End;
-            in_include_x_y,
-            in_exclude_x_y:
-              begin
-                 secondpass(p^.left^.left);
-                 if p^.left^.right^.left^.treetype=ordconstn then
-                   begin
-                      { calculate bit position }
-                      l:=1 shl (p^.left^.right^.left^.value mod 32);
-
-                      { determine operator }
-                      if p^.inlinenumber=in_include_x_y then
-                        asmop:=A_OR
-                      else
-                        begin
-                           asmop:=A_AND;
-                           l:=not(l);
-                        end;
-                      if (p^.left^.left^.location.loc=LOC_REFERENCE) then
-                        begin
-                           inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4);
-                           emit_const_ref(asmop,S_L,
-                             l,newreference(p^.left^.left^.location.reference));
-                           del_reference(p^.left^.left^.location.reference);
-                        end
-                      else
-                        { LOC_CREGISTER }
-                        emit_const_reg(asmop,S_L,
-                          l,p^.left^.left^.location.register);
-                   end
-                 else
-                   begin
-                      { generate code for the element to set }
-                      ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left,false);
-                      secondpass(p^.left^.right^.left);
-                      if ispushed then
-                        restore(p^.left^.left,false);
-                      { determine asm operator }
-                      if p^.inlinenumber=in_include_x_y then
-                        asmop:=A_BTS
-                      else
-                        asmop:=A_BTR;
-                      if psetdef(p^.left^.resulttype)^.settype=smallset then
-                        begin
-                           if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
-                             { we don't need a mod 32 because this is done automatically  }
-                             { by the bts instruction. For proper checking we would       }
-                             { need a cmp and jmp, but this should be done by the         }
-                             { type cast code which does range checking if necessary (FK) }
-                             hregister:=makereg32(p^.left^.right^.left^.location.register)
-                           else
-                             begin
-{$ifndef noAllocEdi}
-                                getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                hregister:=R_EDI;
-                                opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef);
-                                if opsize in [S_B,S_W,S_L] then
-                                 op:=A_MOV
-                                else
-                                 op:=A_MOVZX;
-                                emit_ref_reg(op,opsize,
-                                  newreference(p^.left^.right^.left^.location.reference),R_EDI);
-                             end;
-                          if (p^.left^.left^.location.loc=LOC_REFERENCE) then
-                            emit_reg_ref(asmop,S_L,hregister,
-                              newreference(p^.left^.left^.location.reference))
-                          else
-                            emit_reg_reg(asmop,S_L,hregister,
-                              p^.left^.left^.location.register);
-{$ifndef noAllocEdi}
-                        if hregister = R_EDI then
-                          ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                        end
-                      else
-                        begin
-                           pushsetelement(p^.left^.right^.left);
-                           { normset is allways a ref }
-                           emitpushreferenceaddr(p^.left^.left^.location.reference);
-                           if p^.inlinenumber=in_include_x_y then
-                             emitcall('FPC_SET_SET_BYTE')
-                           else
-                             emitcall('FPC_SET_UNSET_BYTE');
-                           {CGMessage(cg_e_include_not_implemented);}
-                        end;
-                   end;
-              end;
-            in_pi:
-              begin
-                emit_none(A_FLDPI,S_NO);
-                inc(fpuvaroffset);
-              end;
-            in_sin_extended,
-            in_arctan_extended,
-            in_abs_extended,
-            in_sqr_extended,
-            in_sqrt_extended,
-            in_ln_extended,
-            in_cos_extended:
-              begin
-                 secondpass(p^.left);
-                 case p^.left^.location.loc of
-                    LOC_FPU:
-                      ;
-                    LOC_CFPUREGISTER:
-                      begin
-                         emit_reg(A_FLD,S_NO,
-                           correct_fpuregister(p^.left^.location.register,fpuvaroffset));
-                         inc(fpuvaroffset);
-                      end;
-                    LOC_REFERENCE,LOC_MEM:
-                      begin
-                         floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference);
-                         del_reference(p^.left^.location.reference);
-                      end
-                    else
-                      internalerror(309991);
-                 end;
-                 case p^.inlinenumber of
-                    in_sin_extended,
-                    in_cos_extended:
-                      begin
-                         if p^.inlinenumber=in_sin_extended then
-                           emit_none(A_FSIN,S_NO)
-                         else
-                           emit_none(A_FCOS,S_NO);
-                         {
-                         getlabel(l1);
-                         emit_reg(A_FNSTSW,S_NO,R_AX);
-                         emit_none(A_SAHF,S_NO);
-                         emitjmp(C_NP,l1);
-                         emit_reg(A_FSTP,S_NO,R_ST0);
-                         emit_none(A_FLDZ,S_NO);
-                         emitlab(l1);
-                         }
-                      end;
-                    in_arctan_extended:
-                      begin
-                         emit_none(A_FLD1,S_NO);
-                         emit_none(A_FPATAN,S_NO);
-                      end;
-                    in_abs_extended:
-                      emit_none(A_FABS,S_NO);
-                    in_sqr_extended:
-                      begin
-                         (* emit_reg(A_FLD,S_NO,R_ST0);
-                         { emit_none(A_FMULP,S_NO); nasm does not accept this PM }
-                         emit_reg_reg(A_FMULP,S_NO,R_ST0,R_ST1);
-                           can be shorten to *)
-                         emit_reg_reg(A_FMUL,S_NO,R_ST0,R_ST0);
-                      end;
-                    in_sqrt_extended:
-                      emit_none(A_FSQRT,S_NO);
-                    in_ln_extended:
-                      begin
-                         emit_none(A_FLDLN2,S_NO);
-                         emit_none(A_FXCH,S_NO);
-                         emit_none(A_FYL2X,S_NO);
-                      end;
-                 end;
-              end;
-{$ifdef SUPPORT_MMX}
-            in_mmx_pcmpeqb..in_mmx_pcmpgtw:
-              begin
-                 if p^.left^.location.loc=LOC_REGISTER then
-                   begin
-                      {!!!!!!!}
-                   end
-                 else if p^.left^.left^.location.loc=LOC_REGISTER then
-                   begin
-                      {!!!!!!!}
-                   end
-                 else
-                   begin
-                      {!!!!!!!}
-                   end;
-              end;
-{$endif SUPPORT_MMX}
-            else internalerror(9);
-         end;
-         { reset pushedparasize }
-         pushedparasize:=oldpushedparasize;
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:56  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.9  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.8  2000/09/24 15:06:11  peter
-    * use defines.inc
-
-  Revision 1.7  2000/08/27 16:11:49  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.6  2000/08/16 13:06:06  florian
-    + support of 64 bit integer constants
-
-  Revision 1.5  2000/08/04 22:00:50  peter
-    * merges from fixes
-
-  Revision 1.4  2000/07/29 18:27:53  sg
-  * Applied patch by Markus Kaemmerer which removes a tiny memory leak
-    for the generation of code for in_[sin|cos]_extended code
-    (a label has been created but never used afterwards)
-
-  Revision 1.3  2000/07/21 15:14:02  jonas
-    + added is_addr field for labels, if they are only used for getting the address
-       (e.g. for io checks) and corresponding getaddrlabel() procedure
-
-  Revision 1.2  2000/07/13 11:32:34  michael
-  + removed logs
-
-}

compiler/old/cg386ld.pas

@@ -1,1073 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for load/assignment nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386ld;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondload(var p : ptree);
-    procedure secondassignment(var p : ptree);
-    procedure secondfuncret(var p : ptree);
-    procedure secondarrayconstruct(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cobjects,verbose,globals,fmodule,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386,cg386cnv,cresstr;
-
-{*****************************************************************************
-                             SecondLoad
-*****************************************************************************}
-
-    procedure secondload(var p : ptree);
-      var
-         hregister : tregister;
-         symtabletype : tsymtabletype;
-         i : longint;
-         hp : preference;
-         s : pasmsymbol;
-         popeax : boolean;
-         pushed : tpushed;
-         hr : treference;
-
-      begin
-         simple_loadn:=true;
-         reset_reference(p^.location.reference);
-         case p^.symtableentry^.typ of
-              { this is only for toasm and toaddr }
-              absolutesym :
-                 begin
-                    p^.location.reference.symbol:=nil;
-                    if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then
-                     begin
-                       if pabsolutesym(p^.symtableentry)^.absseg then
-                        p^.location.reference.segment:=R_FS;
-                       p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address;
-                     end
-                    else
-                     p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                 end;
-              constsym:
-                begin
-                   if pconstsym(p^.symtableentry)^.consttyp=constresourcestring then
-                     begin
-                         pushusedregisters(pushed,$ff);
-                         emit_const(A_PUSH,S_L,
-                           pconstsym(p^.symtableentry)^.resstrindex);
-                         emit_sym(A_PUSH,S_L,newasmsymbol(pconstsym(p^.symtableentry)^.owner^.name^+'_RESOURCESTRINGLIST'));
-                         emitcall('FPC_GETRESOURCESTRING');
-
-                         hregister:=getexplicitregister32(R_EAX);
-                         emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                         gettempansistringreference(hr);
-                         decrstringref(p^.resulttype,hr);
-                         emit_reg_ref(A_MOV,S_L,hregister,
-                           newreference(hr));
-                        ungetregister32(hregister);
-                        popusedregisters(pushed);
-
-                        p^.location.loc:=LOC_MEM;
-                        p^.location.reference:=hr;
-                     end
-                   else
-                     internalerror(22798);
-                end;
-              varsym :
-                 begin
-                    hregister:=R_NO;
-                    { C variable }
-                    if (vo_is_C_var in pvarsym(p^.symtableentry)^.varoptions) then
-                      begin
-                         p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                      end
-                    { DLL variable }
-                    else if (vo_is_dll_var in pvarsym(p^.symtableentry)^.varoptions) then
-                      begin
-                         hregister:=getregister32;
-                         p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                         emit_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister);
-                         p^.location.reference.symbol:=nil;
-                         p^.location.reference.base:=hregister;
-                      end
-                    { external variable }
-                    else if (vo_is_external in pvarsym(p^.symtableentry)^.varoptions) then
-                      begin
-                         p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                      end
-                    { thread variable }
-                    else if (vo_is_thread_var in pvarsym(p^.symtableentry)^.varoptions) then
-                      begin
-                         popeax:=not(R_EAX in unused);
-                         if popeax then
-                           emit_reg(A_PUSH,S_L,R_EAX);
-                         p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                         emit_ref(A_PUSH,S_L,newreference(p^.location.reference));
-                         { the called procedure isn't allowed to change }
-                         { any register except EAX                    }
-                         emitcall('FPC_RELOCATE_THREADVAR');
-
-                         reset_reference(p^.location.reference);
-                         p^.location.reference.base:=getregister32;
-                         emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.reference.base);
-                         if popeax then
-                           emit_reg(A_POP,S_L,R_EAX);
-
-                      end
-                    { normal variable }
-                    else
-                      begin
-                         symtabletype:=p^.symtable^.symtabletype;
-                         { in case it is a register variable: }
-                         if pvarsym(p^.symtableentry)^.reg<>R_NO then
-                           begin
-                              if pvarsym(p^.symtableentry)^.reg in [R_ST0..R_ST7] then
-                                begin
-                                   p^.location.loc:=LOC_CFPUREGISTER;
-                                   p^.location.register:=pvarsym(p^.symtableentry)^.reg;
-                                end
-                              else
-                                begin
-                                   p^.location.loc:=LOC_CREGISTER;
-                                   p^.location.register:=pvarsym(p^.symtableentry)^.reg;
-                                   unused:=unused-[pvarsym(p^.symtableentry)^.reg];
-                                end;
-                           end
-                         else
-                           begin
-                              { first handle local and temporary variables }
-                              if (symtabletype in [parasymtable,inlinelocalsymtable,
-                                                   inlineparasymtable,localsymtable]) then
-                                begin
-                                   p^.location.reference.base:=procinfo^.framepointer;
-                                   if (symtabletype in [inlinelocalsymtable,
-                                                        localsymtable]) then
-                                     p^.location.reference.offset:=
-                                       pvarsym(p^.symtableentry)^.address-p^.symtable^.address_fixup
-                                   else
-                                     p^.location.reference.offset:=
-                                       pvarsym(p^.symtableentry)^.address+p^.symtable^.address_fixup;
-
-                                   if (symtabletype in [localsymtable,inlinelocalsymtable]) then
-                                     begin
-                                        if use_esp_stackframe then
-                                          dec(p^.location.reference.offset,
-                                            pvarsym(p^.symtableentry)^.getvaluesize)
-                                        else
-                                          p^.location.reference.offset:=-p^.location.reference.offset;
-                                     end;
-                                   if (lexlevel>(p^.symtable^.symtablelevel)) then
-                                     begin
-                                        hregister:=getregister32;
-
-                                        { make a reference }
-                                        hp:=new_reference(procinfo^.framepointer,
-                                          procinfo^.framepointer_offset);
-
-                                        emit_ref_reg(A_MOV,S_L,hp,hregister);
-
-                                        simple_loadn:=false;
-                                        i:=lexlevel-1;
-                                        while i>(p^.symtable^.symtablelevel) do
-                                          begin
-                                             { make a reference }
-                                             hp:=new_reference(hregister,8);
-                                             emit_ref_reg(A_MOV,S_L,hp,hregister);
-                                             dec(i);
-                                          end;
-                                        p^.location.reference.base:=hregister;
-                                     end;
-                                end
-                              else
-                                case symtabletype of
-                                   unitsymtable,globalsymtable,
-                                   staticsymtable :
-                                     begin
-                                       p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                                     end;
-                                   stt_exceptsymtable:
-                                     begin
-                                        p^.location.reference.base:=procinfo^.framepointer;
-                                        p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
-                                     end;
-                                   objectsymtable:
-                                     begin
-                                        getexplicitregister32(R_ESI);
-                                        if (sp_static in pvarsym(p^.symtableentry)^.symoptions) then
-                                          begin
-                                             p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                                          end
-                                        else
-                                          begin
-                                             p^.location.reference.base:=R_ESI;
-                                             p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
-                                          end;
-                                     end;
-                                   withsymtable:
-                                     begin
-                                        { make a reference }
-                                        { symtable datasize field
-                                          contains the offset of the temp
-                                          stored }
-{                                       hp:=new_reference(procinfo^.framepointer,
-                                          p^.symtable^.datasize);
-
-                                        emit_ref_reg(A_MOV,S_L,hp,hregister);}
-
-                                        if ptree(pwithsymtable(p^.symtable)^.withnode)^.islocal then
-                                         begin
-                                           p^.location.reference:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^;
-                                         end
-                                        else
-                                         begin
-                                           hregister:=getregister32;
-                                           p^.location.reference.base:=hregister;
-                                           emit_ref_reg(A_MOV,S_L,
-                                             newreference(ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^),
-                                             hregister);
-                                         end;
-                                        inc(p^.location.reference.offset,pvarsym(p^.symtableentry)^.address);
-                                     end;
-                                end;
-                           end;
-                         { in case call by reference, then calculate. Open array
-                           is always an reference! }
-                         if (pvarsym(p^.symtableentry)^.varspez in [vs_var,vs_out]) or
-                            is_open_array(pvarsym(p^.symtableentry)^.vartype.def) or
-                            is_array_of_const(pvarsym(p^.symtableentry)^.vartype.def) or
-                            ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
-                             push_addr_param(pvarsym(p^.symtableentry)^.vartype.def)) then
-                           begin
-                              simple_loadn:=false;
-                              if hregister=R_NO then
-                                hregister:=getregister32;
-                              if p^.location.loc=LOC_CREGISTER then
-                                begin
-                                   emit_reg_reg(A_MOV,S_L,
-                                     p^.location.register,hregister);
-                                   p^.location.loc:=LOC_REFERENCE;
-                                end
-                              else
-                                begin
-                                   emit_ref_reg(A_MOV,S_L,
-                                     newreference(p^.location.reference),
-                                     hregister);
-                                end;
-                              reset_reference(p^.location.reference);
-                              p^.location.reference.base:=hregister;
-                          end;
-                      end;
-                 end;
-              procsym:
-                 begin
-                    if assigned(p^.left) then
-                      begin
-                         secondpass(p^.left);
-                         p^.location.loc:=LOC_MEM;
-                         gettempofsizereference(8,p^.location.reference);
-
-                         { load class instance address }
-                         case p^.left^.location.loc of
-
-                            LOC_CREGISTER,
-                            LOC_REGISTER:
-                              begin
-                                 hregister:=p^.left^.location.register;
-                                 ungetregister32(p^.left^.location.register);
-                                 if (p^.left^.resulttype^.deftype<>classrefdef) and
-                                    (p^.left^.resulttype^.deftype<>objectdef) and
-                                    not(pobjectdef(p^.left^.resulttype)^.is_class) then
-                                   CGMessage(cg_e_illegal_expression);
-                              end;
-
-                            LOC_MEM,
-                            LOC_REFERENCE:
-                              begin
-{$ifndef noAllocEdi}
-                                 getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                 hregister:=R_EDI;
-                                 if pobjectdef(p^.left^.resulttype)^.is_class then
-                                   emit_ref_reg(A_MOV,S_L,
-                                     newreference(p^.left^.location.reference),R_EDI)
-                                 else
-                                   emit_ref_reg(A_LEA,S_L,
-                                     newreference(p^.left^.location.reference),R_EDI);
-                                 del_reference(p^.left^.location.reference);
-                                 ungetiftemp(p^.left^.location.reference);
-                              end;
-                            else internalerror(26019);
-                         end;
-
-                         { store the class instance address }
-                         new(hp);
-                         hp^:=p^.location.reference;
-                         inc(hp^.offset,4);
-                         emit_reg_ref(A_MOV,S_L,
-                           hregister,hp);
-
-                         { virtual method ? }
-                         if (po_virtualmethod in pprocsym(p^.symtableentry)^.definition^.procoptions) then
-                           begin
-                              new(hp);
-                              reset_reference(hp^);
-                              hp^.base:=hregister;
-                              { load vmt pointer }
-                              emit_ref_reg(A_MOV,S_L,
-                                hp,R_EDI);
-{$IfDef regallocfix}
-                              del_reference(hp^);
-{$EndIf regallocfix}
-                              { load method address }
-                              new(hp);
-                              reset_reference(hp^);
-                              hp^.base:=R_EDI;
-                              hp^.offset:=pprocsym(p^.symtableentry)^.definition^._class^.vmtmethodoffset(
-                                pprocsym(p^.symtableentry)^.definition^.extnumber);
-                              emit_ref_reg(A_MOV,S_L,
-                                hp,R_EDI);
-                              { ... and store it }
-                              emit_reg_ref(A_MOV,S_L,
-                                R_EDI,newreference(p^.location.reference));
-{$ifndef noAllocEdi}
-                              ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                           end
-                         else
-                           begin
-{$ifndef noAllocEdi}
-                              ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                              s:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname);
-                              emit_sym_ofs_ref(A_MOV,S_L,s,0,
-                                newreference(p^.location.reference));
-                           end;
-                      end
-                    else
-                      begin
-                         {!!!!! Be aware, work on virtual methods too }
-                         p^.location.reference.symbol:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname);
-                      end;
-                 end;
-              typedconstsym :
-                 begin
-                    p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
-                 end;
-              else internalerror(4);
-         end;
-      end;
-
-
-{*****************************************************************************
-                             SecondAssignment
-*****************************************************************************}
-
-    procedure secondassignment(var p : ptree);
-      var
-         opsize : topsize;
-         otlabel,hlabel,oflabel : pasmlabel;
-         fputyp : tfloattype;
-         loc : tloc;
-         r : preference;
-         ai : paicpu;
-         op : tasmop;
-         pushed : boolean;
-         regspushed : tpushed;
-         regs_to_push: byte;
-         ungettemp : boolean;
-
-      begin
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         { calculate left sides }
-         if not(p^.concat_string) then
-           secondpass(p^.left);
-
-         if codegenerror then
-           exit;
-
-         if not(p^.left^.location.loc in [LOC_REFERENCE,LOC_CFPUREGISTER,
-           LOC_CREGISTER,LOC_CMMXREGISTER]) then
-           begin
-              CGMessage(cg_e_illegal_expression);
-              exit;
-           end;
-
-
-         loc:=p^.left^.location.loc;
-         { lets try to optimize this (PM)            }
-         { define a dest_loc that is the location      }
-         { and a ptree to verify that it is the right }
-         { place to insert it                    }
-{$ifdef test_dest_loc}
-         if (aktexprlevel<4) then
-           begin
-              dest_loc_known:=true;
-              dest_loc:=p^.left^.location;
-              dest_loc_tree:=p^.right;
-           end;
-{$endif test_dest_loc}
-
-         { left can't be never a 64 bit LOC_REGISTER, so the 3. arg }
-         { can be false                                             }
-         pushed:=maybe_push(p^.right^.registers32,p^.left,false);
-         secondpass(p^.right);
-
-         { restoring here is nonsense for LOC_JMP !! }
-         { This generated code that was after a jmp and before any
-           label => unreachable !!
-           Could this be tested somehow ?? PM }
-         if pushed and (p^.right^.location.loc <>LOC_JUMP) then
-           restore(p^.left,false);
-
-         if codegenerror then
-           exit;
-
-{$ifdef test_dest_loc}
-         dest_loc_known:=false;
-         if in_dest_loc then
-           begin
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-              in_dest_loc:=false;
-              exit;
-           end;
-{$endif test_dest_loc}
-         if p^.left^.resulttype^.deftype=stringdef then
-           begin
-              if is_ansistring(p^.left^.resulttype) then
-                begin
-                  { before pushing any parameter, we have to save all used      }
-                  { registers, but before that we have to release the       }
-                  { registers of that node to save uneccessary pushed       }
-                  { so be careful, if you think you can optimize that code (FK) }
-
-                  { nevertheless, this has to be changed, because otherwise the }
-                  { register is released before it's contents are pushed ->     }
-                  { problems with the optimizer (JM)                            }
-                  del_reference(p^.left^.location.reference);
-                  ungettemp:=false;
-                  { Find out which registers have to be pushed (JM) }
-                  regs_to_push := $ff;
-                  remove_non_regvars_from_loc(p^.right^.location,regs_to_push);
-                  { And push them (JM) }
-                  pushusedregisters(regspushed,regs_to_push);
-                  case p^.right^.location.loc of
-                     LOC_REGISTER,LOC_CREGISTER:
-                       begin
-                          exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register)));
-                          ungetregister32(p^.right^.location.register);
-                       end;
-                     LOC_REFERENCE,LOC_MEM:
-                       begin
-                          { First release the registers because emit_push_mem may  }
-                          { load the reference in edi before pushing and then the  }
-                          { dealloc is too late (and optimizations are missed (JM) }
-                          del_reference(p^.right^.location.reference);
-                          { This one doesn't need extra registers (JM) }
-                          emit_push_mem(p^.right^.location.reference);
-                          ungettemp:=true;
-                       end;
-                  end;
-                  emitpushreferenceaddr(p^.left^.location.reference);
-                  del_reference(p^.left^.location.reference);
-                  emitcall('FPC_ANSISTR_ASSIGN');
-                  maybe_loadesi;
-                  popusedregisters(regspushed);
-                  if ungettemp then
-                    ungetiftemp(p^.right^.location.reference);
-                end
-              else
-              if is_shortstring(p^.left^.resulttype) and
-                not (p^.concat_string) then
-                begin
-                  if is_ansistring(p^.right^.resulttype) then
-                    begin
-                      if (p^.right^.treetype=stringconstn) and
-                         (p^.right^.length=0) then
-                        begin
-                          emit_const_ref(A_MOV,S_B,
-                            0,newreference(p^.left^.location.reference));
-                          del_reference(p^.left^.location.reference);
-                        end
-                      else
-                        loadansi2short(p^.right,p^.left);
-                    end
-                  else
-                    begin
-                       { we do not need destination anymore }
-                       del_reference(p^.left^.location.reference);
-                       {del_reference(p^.right^.location.reference);
-                        done in loadshortstring }
-                       loadshortstring(p);
-                       ungetiftemp(p^.right^.location.reference);
-                    end;
-                end
-              else if is_longstring(p^.left^.resulttype) then
-                begin
-                end
-              else
-                begin
-                  { its the only thing we have to do }
-                  del_reference(p^.right^.location.reference);
-                end
-           end
-        else case p^.right^.location.loc of
-            LOC_REFERENCE,
-            LOC_MEM : begin
-                         { extra handling for ordinal constants }
-                         if (p^.right^.treetype in [ordconstn,fixconstn]) or
-                            (loc=LOC_CREGISTER) then
-                           begin
-                              case p^.left^.resulttype^.size of
-                                 1 : opsize:=S_B;
-                                 2 : opsize:=S_W;
-                                 4 : opsize:=S_L;
-                                 { S_L is correct, the copy is done }
-                                 { with two moves                   }
-                                 8 : opsize:=S_L;
-                              end;
-                              if loc=LOC_CREGISTER then
-                                begin
-                                  emit_ref_reg(A_MOV,opsize,
-                                    newreference(p^.right^.location.reference),
-                                    p^.left^.location.register);
-                                  if is_64bitint(p^.right^.resulttype) then
-                                    begin
-                                       r:=newreference(p^.right^.location.reference);
-                                       inc(r^.offset,4);
-                                       emit_ref_reg(A_MOV,opsize,r,
-                                         p^.left^.location.registerhigh);
-                                    end;
-{$IfDef regallocfix}
-                                  del_reference(p^.right^.location.reference);
-{$EndIf regallocfix}
-                                end
-                              else
-                                begin
-                                  if is_64bitint(p^.right^.resulttype) then
-                                    begin
-                                       emit_const_ref(A_MOV,opsize,
-                                         lo(p^.right^.value),
-                                         newreference(p^.left^.location.reference));
-                                       r:=newreference(p^.left^.location.reference);
-                                       inc(r^.offset,4);
-                                       emit_const_ref(A_MOV,opsize,
-                                         hi(p^.right^.value),r);
-                                    end
-                                  else
-                                    begin
-                                       emit_const_ref(A_MOV,opsize,
-                                         p^.right^.location.reference.offset,
-                                         newreference(p^.left^.location.reference));
-                                    end;
-{$IfDef regallocfix}
-                                  del_reference(p^.left^.location.reference);
-{$EndIf regallocfix}
-                                {emit_const_loc(A_MOV,opsize,
-                                    p^.right^.location.reference.offset,
-                                    p^.left^.location);}
-                                end;
-
-                           end
-                         else if loc=LOC_CFPUREGISTER then
-                           begin
-                              floatloadops(pfloatdef(p^.right^.resulttype)^.typ,op,opsize);
-                              emit_ref(op,opsize,
-                                newreference(p^.right^.location.reference));
-                              emit_reg(A_FSTP,S_NO,
-                                correct_fpuregister(p^.left^.location.register,fpuvaroffset+1));
-                           end
-                         else
-                           begin
-                              if (p^.right^.resulttype^.needs_inittable) and
-                                ( (p^.right^.resulttype^.deftype<>objectdef) or
-                                  not(pobjectdef(p^.right^.resulttype)^.is_class)) then
-                                begin
-                                   { this would be a problem }
-                                   if not(p^.left^.resulttype^.needs_inittable) then
-                                     internalerror(3457);
-
-                                   { increment source reference counter }
-                                   new(r);
-                                   reset_reference(r^);
-                                   r^.symbol:=p^.right^.resulttype^.get_inittable_label;
-                                   emitpushreferenceaddr(r^);
-
-                                   emitpushreferenceaddr(p^.right^.location.reference);
-                                   emitcall('FPC_ADDREF');
-                                   { decrement destination reference counter }
-                                   new(r);
-                                   reset_reference(r^);
-                                   r^.symbol:=p^.left^.resulttype^.get_inittable_label;
-                                   emitpushreferenceaddr(r^);
-                                   emitpushreferenceaddr(p^.left^.location.reference);
-                                   emitcall('FPC_DECREF');
-                                end;
-
-{$ifdef regallocfix}
-                              concatcopy(p^.right^.location.reference,
-                                p^.left^.location.reference,p^.left^.resulttype^.size,true,false);
-                              ungetiftemp(p^.right^.location.reference);
-{$Else regallocfix}
-                              concatcopy(p^.right^.location.reference,
-                                p^.left^.location.reference,p^.left^.resulttype^.size,false,false);
-                              ungetiftemp(p^.right^.location.reference);
-{$endif regallocfix}
-                           end;
-                      end;
-{$ifdef SUPPORT_MMX}
-            LOC_CMMXREGISTER,
-            LOC_MMXREGISTER:
-              begin
-                 if loc=LOC_CMMXREGISTER then
-                   emit_reg_reg(A_MOVQ,S_NO,
-                   p^.right^.location.register,p^.left^.location.register)
-                 else
-                   emit_reg_ref(A_MOVQ,S_NO,
-                     p^.right^.location.register,newreference(p^.left^.location.reference));
-              end;
-{$endif SUPPORT_MMX}
-            LOC_REGISTER,
-            LOC_CREGISTER : begin
-                              case p^.right^.resulttype^.size of
-                                 1 : opsize:=S_B;
-                                 2 : opsize:=S_W;
-                                 4 : opsize:=S_L;
-                                 8 : opsize:=S_L;
-                              end;
-                              { simplified with op_reg_loc       }
-                              if loc=LOC_CREGISTER then
-                                begin
-                                  emit_reg_reg(A_MOV,opsize,
-                                    p^.right^.location.register,
-                                    p^.left^.location.register);
-                                 ungetregister(p^.right^.location.register);
-                                end
-                              else
-                                Begin
-                                  emit_reg_ref(A_MOV,opsize,
-                                    p^.right^.location.register,
-                                    newreference(p^.left^.location.reference));
-                                  ungetregister(p^.right^.location.register);
-{$IfDef regallocfix}
-                                  del_reference(p^.left^.location.reference);
-{$EndIf regallocfix}
-                                end;
-                              if is_64bitint(p^.right^.resulttype) then
-                                begin
-                                   { simplified with op_reg_loc  }
-                                   if loc=LOC_CREGISTER then
-                                     emit_reg_reg(A_MOV,opsize,
-                                       p^.right^.location.registerhigh,
-                                       p^.left^.location.registerhigh)
-                                   else
-                                     begin
-                                        r:=newreference(p^.left^.location.reference);
-                                        inc(r^.offset,4);
-                                        emit_reg_ref(A_MOV,opsize,
-                                          p^.right^.location.registerhigh,r);
-                                     end;
-                                end;
-                              {emit_reg_loc(A_MOV,opsize,
-                                  p^.right^.location.register,
-                                  p^.left^.location);      }
-
-                           end;
-            LOC_FPU : begin
-                              if (p^.left^.resulttype^.deftype=floatdef) then
-                               fputyp:=pfloatdef(p^.left^.resulttype)^.typ
-                              else
-                               if (p^.right^.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(p^.right^.resulttype)^.typ
-                              else
-                               if (p^.right^.treetype=typeconvn) and
-                                  (p^.right^.left^.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ
-                              else
-                                fputyp:=s32real;
-                              case loc of
-                                 LOC_CFPUREGISTER:
-                                   begin
-                                      emit_reg(A_FSTP,S_NO,
-                                        correct_fpuregister(p^.left^.location.register,fpuvaroffset));
-                                      dec(fpuvaroffset);
-                                   end;
-                                 LOC_REFERENCE:
-                                   floatstore(fputyp,p^.left^.location.reference);
-                                 else
-                                   internalerror(48991);
-                              end;
-                           end;
-            LOC_CFPUREGISTER: begin
-                              if (p^.left^.resulttype^.deftype=floatdef) then
-                               fputyp:=pfloatdef(p^.left^.resulttype)^.typ
-                              else
-                               if (p^.right^.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(p^.right^.resulttype)^.typ
-                              else
-                               if (p^.right^.treetype=typeconvn) and
-                                  (p^.right^.left^.resulttype^.deftype=floatdef) then
-                                fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ
-                              else
-                                fputyp:=s32real;
-                              emit_reg(A_FLD,S_NO,
-                                correct_fpuregister(p^.right^.location.register,fpuvaroffset));
-                              inc(fpuvaroffset);
-                              case loc of
-                                 LOC_CFPUREGISTER:
-                                   begin
-                                      emit_reg(A_FSTP,S_NO,
-                                        correct_fpuregister(p^.right^.location.register,fpuvaroffset));
-                                      dec(fpuvaroffset);
-                                   end;
-                                 LOC_REFERENCE:
-                                   floatstore(fputyp,p^.left^.location.reference);
-                                 else
-                                   internalerror(48992);
-                              end;
-                           end;
-            LOC_JUMP     : begin
-                              getlabel(hlabel);
-                              emitlab(truelabel);
-                              if pushed then
-                                restore(p^.left,false);
-                              if loc=LOC_CREGISTER then
-                                emit_const_reg(A_MOV,S_B,
-                                  1,p^.left^.location.register)
-                              else
-                                emit_const_ref(A_MOV,S_B,
-                                  1,newreference(p^.left^.location.reference));
-                              {emit_const_loc(A_MOV,S_B,
-                                  1,p^.left^.location);}
-                              emitjmp(C_None,hlabel);
-                              emitlab(falselabel);
-                              if pushed then
-                                restore(p^.left,false);
-                              if loc=LOC_CREGISTER then
-                                emit_reg_reg(A_XOR,S_B,
-                                  p^.left^.location.register,
-                                  p^.left^.location.register)
-                              else
-                                begin
-                                  emit_const_ref(A_MOV,S_B,
-                                    0,newreference(p^.left^.location.reference));
-{$IfDef regallocfix}
-                                  del_reference(p^.left^.location.reference);
-{$EndIf regallocfix}
-                                 end;
-                              emitlab(hlabel);
-                           end;
-            LOC_FLAGS    : begin
-                              if loc=LOC_CREGISTER then
-                                emit_flag2reg(p^.right^.location.resflags,p^.left^.location.register)
-                              else
-                                begin
-                                  ai:=new(paicpu,op_ref(A_Setcc,S_B,newreference(p^.left^.location.reference)));
-                                  ai^.SetCondition(flag_2_cond[p^.right^.location.resflags]);
-                                  exprasmlist^.concat(ai);
-                                end;
-{$IfDef regallocfix}
-                              del_reference(p^.left^.location.reference);
-{$EndIf regallocfix}
-                           end;
-         end;
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-      end;
-
-
-{*****************************************************************************
-                             SecondFuncRet
-*****************************************************************************}
-
-    procedure secondfuncret(var p : ptree);
-      var
-         hr : tregister;
-         hp : preference;
-         pp : pprocinfo;
-         hr_valid : boolean;
-      begin
-         reset_reference(p^.location.reference);
-         hr_valid:=false;
-         if (not inlining_procedure) and
-            (procinfo<>pprocinfo(p^.funcretprocinfo)) then
-           begin
-              hr:=getregister32;
-              hr_valid:=true;
-              hp:=new_reference(procinfo^.framepointer,
-                procinfo^.framepointer_offset);
-              emit_ref_reg(A_MOV,S_L,hp,hr);
-              pp:=procinfo^.parent;
-              { walk up the stack frame }
-              while pp<>pprocinfo(p^.funcretprocinfo) do
-                begin
-                   hp:=new_reference(hr,
-                     pp^.framepointer_offset);
-                   emit_ref_reg(A_MOV,S_L,hp,hr);
-                   pp:=pp^.parent;
-                end;
-              p^.location.reference.base:=hr;
-              p^.location.reference.offset:=pp^.return_offset;
-           end
-         else
-           begin
-             p^.location.reference.base:=procinfo^.framepointer;
-             p^.location.reference.offset:=procinfo^.return_offset;
-           end;
-         if ret_in_param(p^.rettype.def) then
-           begin
-              if not hr_valid then
-                hr:=getregister32;
-              emit_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr);
-              p^.location.reference.base:=hr;
-              p^.location.reference.offset:=0;
-           end;
-      end;
-
-
-{*****************************************************************************
-                           SecondArrayConstruct
-*****************************************************************************}
-
-      const
-        vtInteger    = 0;
-        vtBoolean    = 1;
-        vtChar       = 2;
-        vtExtended   = 3;
-        vtString     = 4;
-        vtPointer    = 5;
-        vtPChar      = 6;
-        vtObject     = 7;
-        vtClass      = 8;
-        vtWideChar   = 9;
-        vtPWideChar  = 10;
-        vtAnsiString = 11;
-        vtCurrency   = 12;
-        vtVariant    = 13;
-        vtInterface  = 14;
-        vtWideString = 15;
-        vtInt64      = 16;
-        vtQWord      = 17;
-
-    procedure secondarrayconstruct(var p : ptree);
-      var
-        hp    : ptree;
-        href  : treference;
-        lt    : pdef;
-        vaddr : boolean;
-        vtype : longint;
-        freetemp,
-        dovariant : boolean;
-        elesize : longint;
-      begin
-        dovariant:=p^.forcevaria or parraydef(p^.resulttype)^.isvariant;
-        if dovariant then
-         elesize:=8
-        else
-         begin
-           elesize:=parraydef(p^.resulttype)^.elesize;
-           if elesize>4 then
-            internalerror(8765678);
-         end;
-        if not p^.cargs then
-         begin
-           reset_reference(p^.location.reference);
-           { Allocate always a temp, also if no elements are required, to
-             be sure that location is valid (PFV) }
-            if parraydef(p^.resulttype)^.highrange=-1 then
-              gettempofsizereference(elesize,p^.location.reference)
-            else
-              gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*elesize,p^.location.reference);
-           href:=p^.location.reference;
-         end;
-        hp:=p;
-        while assigned(hp) do
-         begin
-           if assigned(hp^.left) then
-            begin
-              freetemp:=true;
-              secondpass(hp^.left);
-              if codegenerror then
-               exit;
-              if dovariant then
-               begin
-                 { find the correct vtype value }
-                 vtype:=$ff;
-                 vaddr:=false;
-                 lt:=hp^.left^.resulttype;
-                 case lt^.deftype of
-                   enumdef,
-                   orddef :
-                     begin
-                       if is_64bitint(lt) then
-                         begin
-                            case porddef(lt)^.typ of
-                               s64bit:
-                                 vtype:=vtInt64;
-                               u64bit:
-                                 vtype:=vtQWord;
-                            end;
-                            freetemp:=false;
-                            vaddr:=true;
-                         end
-                       else if (lt^.deftype=enumdef) or
-                         is_integer(lt) then
-                         vtype:=vtInteger
-                       else
-                         if is_boolean(lt) then
-                           vtype:=vtBoolean
-                         else
-                           if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
-                             vtype:=vtChar;
-                     end;
-                   floatdef :
-                     begin
-                       vtype:=vtExtended;
-                       vaddr:=true;
-                       freetemp:=false;
-                     end;
-                   procvardef,
-                   pointerdef :
-                     begin
-                       if is_pchar(lt) then
-                         vtype:=vtPChar
-                       else
-                         vtype:=vtPointer;
-                     end;
-                   classrefdef :
-                     vtype:=vtClass;
-                   objectdef :
-                     begin
-                       vtype:=vtObject;
-                     end;
-                   stringdef :
-                     begin
-                       if is_shortstring(lt) then
-                        begin
-                          vtype:=vtString;
-                          vaddr:=true;
-                          freetemp:=false;
-                        end
-                       else
-                        if is_ansistring(lt) then
-                         begin
-                           vtype:=vtAnsiString;
-                           freetemp:=false;
-                         end;
-                     end;
-                 end;
-                 if vtype=$ff then
-                   internalerror(14357);
-                 { write C style pushes or an pascal array }
-                 if p^.cargs then
-                  begin
-                    if vaddr then
-                     begin
-                       emit_to_mem(hp^.left^.location,hp^.left^.resulttype);
-                       emit_push_lea_loc(hp^.left^.location,freetemp);
-                       del_reference(hp^.left^.location.reference);
-                     end
-                    else
-                     emit_push_loc(hp^.left^.location);
-                    inc(pushedparasize);
-                  end
-                 else
-                  begin
-                    { write changing field update href to the next element }
-                    inc(href.offset,4);
-                    if vaddr then
-                     begin
-                       emit_to_mem(hp^.left^.location,hp^.left^.resulttype);
-                       emit_lea_loc_ref(hp^.left^.location,href,freetemp);
-                     end
-                    else
-                     begin
-                       emit_mov_loc_ref(hp^.left^.location,href,S_L,freetemp);
-                     end;
-                    { update href to the vtype field and write it }
-                    dec(href.offset,4);
-                    emit_const_ref(A_MOV,S_L,vtype,newreference(href));
-                    { goto next array element }
-                    inc(href.offset,8);
-                  end;
-               end
-              else
-              { normal array constructor of the same type }
-               begin
-                 case elesize of
-                   1 :
-                     emit_mov_loc_ref(hp^.left^.location,href,S_B,freetemp);
-                   2 :
-                     emit_mov_loc_ref(hp^.left^.location,href,S_W,freetemp);
-                   4 :
-                     emit_mov_loc_ref(hp^.left^.location,href,S_L,freetemp);
-                   else
-                     internalerror(87656781);
-                 end;
-                 inc(href.offset,elesize);
-               end;
-            end;
-           { load next entry }
-           hp:=hp^.right;
-         end;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.7  2000/09/30 16:08:45  peter
-    * more cg11 updates
-
-  Revision 1.6  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.5  2000/08/27 16:11:49  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.4  2000/08/16 13:06:06  florian
-    + support of 64 bit integer constants
-
-  Revision 1.3  2000/07/13 12:08:25  michael
-  + patched to 1.1.0 with former 1.09patch from peter
-
-  Revision 1.2  2000/07/13 11:32:34  michael
-  + removed logs
-
-}

compiler/old/cg386mat.pas

@@ -1,1022 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for math nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386mat;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondmoddiv(var p : ptree);
-    procedure secondshlshr(var p : ptree);
-    procedure secondunaryminus(var p : ptree);
-    procedure secondnot(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-{$ifdef dummy}
-      end  { this overcomes the annoying highlighting problem in my TP IDE,
-             the IDE assumes i386asm start a asm block (FK) }
-{$endif}
-      cgai386,tgeni386;
-
-{*****************************************************************************
-                             SecondModDiv
-*****************************************************************************}
-
-    procedure secondmoddiv(var p : ptree);
-      var
-         hreg1 : tregister;
-         hreg2 : tregister;
-         shrdiv, andmod, pushed,popeax,popedx : boolean;
-
-         power : longint;
-         hl : pasmlabel;
-         hloc : tlocation;
-         pushedreg : tpushed;
-         typename,opname : string[6];
-
-      begin
-         shrdiv := false;
-         andmod := false;
-         secondpass(p^.left);
-         pushed:=maybe_push(p^.right^.registers32,p^.left,is_64bitint(p^.left^.resulttype));
-         secondpass(p^.right);
-         if pushed then
-           restore(p^.left,is_64bitint(p^.left^.resulttype));
-         set_location(p^.location,p^.left^.location);
-
-         if is_64bitint(p^.resulttype) then
-           begin
-              { save p^.lcoation, because we change it now }
-              set_location(hloc,p^.location);
-              release_qword_loc(p^.location);
-              release_qword_loc(p^.right^.location);
-              p^.location.registerlow:=getexplicitregister32(R_EAX);
-              p^.location.registerhigh:=getexplicitregister32(R_EDX);
-              pushusedregisters(pushedreg,$ff
-                and not($80 shr byte(p^.location.registerlow))
-                and not($80 shr byte(p^.location.registerhigh)));
-              { the left operand is in hloc, because the
-                location of left is p^.location but p^.location
-                is already destroyed
-              }
-              emit_pushq_loc(hloc);
-              clear_location(hloc);
-              emit_pushq_loc(p^.right^.location);
-
-              if porddef(p^.resulttype)^.typ=u64bit then
-                typename:='QWORD'
-              else
-                typename:='INT64';
-              if p^.treetype=divn then
-                opname:='DIV_'
-              else
-                opname:='MOD_';
-              emitcall('FPC_'+opname+typename);
-
-              emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.registerlow);
-              emit_reg_reg(A_MOV,S_L,R_EDX,p^.location.registerhigh);
-              popusedregisters(pushedreg);
-              p^.location.loc:=LOC_REGISTER;
-           end
-         else
-           begin
-              { put numerator in register }
-              if p^.left^.location.loc<>LOC_REGISTER then
-                begin
-                   if p^.left^.location.loc=LOC_CREGISTER then
-                     begin
-                       hreg1:=getregister32;
-                       emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hreg1);
-                     end
-                   else
-                     begin
-                       del_reference(p^.left^.location.reference);
-                       hreg1:=getregister32;
-                       emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
-                         hreg1);
-                     end;
-                   clear_location(p^.left^.location);
-                   p^.left^.location.loc:=LOC_REGISTER;
-                   p^.left^.location.register:=hreg1;
-                end
-              else hreg1:=p^.left^.location.register;
-
-                if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
-                    ispowerof2(p^.right^.value,power) then
-                  Begin
-                    shrdiv := true;
-                    {for signed numbers, the numerator must be adjusted before the
-                     shift instruction, but not wih unsigned numbers! Otherwise,
-                     "Cardinal($ffffffff) div 16" overflows! (JM)}
-                    If is_signed(p^.left^.resulttype) Then
-                      Begin
-                        If (aktOptProcessor <> class386) and
-                           not(CS_LittleSize in aktglobalswitches) then
-                        { use a sequence without jumps, saw this in
-                          comp.compilers (JM) }
-                          begin
-                          { no jumps, but more operations }
-                            if (hreg1 = R_EAX) and
-                               (R_EDX in unused) then
-                              begin
-                                hreg2 := getexplicitregister32(R_EDX);
-                                emit_none(A_CDQ,S_NO);
-                              end
-                            else
-                              begin
-{$ifndef noAllocEdi}
-                                getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                                hreg2 := R_EDI;
-                                emit_reg_reg(A_MOV,S_L,hreg1,R_EDI);
-                              { if the left value is signed, R_EDI := $ffffffff,
-                                otherwise 0 }
-                                emit_const_reg(A_SAR,S_L,31,R_EDI);
-                            { if signed, R_EDI := right value-1, otherwise 0 }
-                              end;
-                            emit_const_reg(A_AND,S_L,p^.right^.value-1,hreg2);
-                          { add to the left value }
-                            emit_reg_reg(A_ADD,S_L,hreg2,hreg1);
-                          { release EDX if we used it }
-{$ifndef noAllocEdi}
-                          { also releas EDI }
-                          ungetregister32(hreg2);
-{$else noAllocEdi}
-                          if (hreg2 = R_EDX) then
-                            ungetregister32(hreg2);
-{$endif noAllocEdi}
-                          { do the shift }
-                            emit_const_reg(A_SAR,S_L,power,hreg1);
-                          end
-                        else
-                          begin
-                          { a jump, but less operations }
-                            emit_reg_reg(A_TEST,S_L,hreg1,hreg1);
-                            getlabel(hl);
-                            emitjmp(C_NS,hl);
-                            if power=1 then
-                              emit_reg(A_INC,S_L,hreg1)
-                            else
-                              emit_const_reg(A_ADD,S_L,p^.right^.value-1,hreg1);
-                            emitlab(hl);
-                            emit_const_reg(A_SAR,S_L,power,hreg1);
-                          end
-                      End
-                    Else
-                      emit_const_reg(A_SHR,S_L,power,hreg1);
-                  End
-                else
-                  if (p^.treetype=modn) and (p^.right^.treetype=ordconstn) and
-                    ispowerof2(p^.right^.value,power) and Not(is_signed(p^.left^.resulttype)) Then
-                   {is there a similar trick for MOD'ing signed numbers? (JM)}
-                   Begin
-                     emit_const_reg(A_AND,S_L,p^.right^.value-1,hreg1);
-                     andmod := true;
-                   End
-                else
-                  begin
-                      { bring denominator to EDI }
-                      { EDI is always free, it's }
-                      { only used for temporary  }
-                      { purposes              }
-{$ifndef noAllocEdi}
-                   getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                   if (p^.right^.location.loc<>LOC_REGISTER) and
-                      (p^.right^.location.loc<>LOC_CREGISTER) then
-                     begin
-                       del_reference(p^.right^.location.reference);
-                       p^.left^.location.loc:=LOC_REGISTER;
-                       emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI);
-                     end
-                   else
-                     begin
-                        emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI);
-                        ungetregister32(p^.right^.location.register);
-                     end;
-                   popedx:=false;
-                   popeax:=false;
-                   if hreg1=R_EDX then
-                     begin
-                       if not(R_EAX in unused) then
-                          begin
-                             emit_reg(A_PUSH,S_L,R_EAX);
-                             popeax:=true;
-                          end;
-                       emit_reg_reg(A_MOV,S_L,R_EDX,R_EAX);
-                     end
-                   else
-                     begin
-                        if not(R_EDX in unused) then
-                          begin
-                             emit_reg(A_PUSH,S_L,R_EDX);
-                             popedx:=true;
-                          end;
-                        if hreg1<>R_EAX then
-                          begin
-                             if not(R_EAX in unused) then
-                               begin
-                                  emit_reg(A_PUSH,S_L,R_EAX);
-                                  popeax:=true;
-                               end;
-                             emit_reg_reg(A_MOV,S_L,hreg1,R_EAX);
-                          end;
-                     end;
-                   { sign extension depends on the left type }
-                   if porddef(p^.left^.resulttype)^.typ=u32bit then
-                      emit_reg_reg(A_XOR,S_L,R_EDX,R_EDX)
-                   else
-                      emit_none(A_CDQ,S_NO);
-
-                   { division depends on the right type }
-                   if porddef(p^.right^.resulttype)^.typ=u32bit then
-                     emit_reg(A_DIV,S_L,R_EDI)
-                   else
-                     emit_reg(A_IDIV,S_L,R_EDI);
-{$ifndef noAllocEdi}
-                   ungetregister32(R_EDI);
-{$endif noAllocEdi}
-                   if p^.treetype=divn then
-                     begin
-                        { if result register is busy then copy }
-                        if popeax then
-                          begin
-                             if hreg1=R_EAX then
-                               internalerror(112);
-                             emit_reg_reg(A_MOV,S_L,R_EAX,hreg1)
-                          end
-                        else
-                          if hreg1<>R_EAX then
-                            Begin
-                              ungetregister32(hreg1);
-                              hreg1 := getexplicitregister32(R_EAX);
-                              { I don't think it's possible that now hreg1 <> R_EAX
-                                since popeax is false, but for all certainty I do
-                                support that situation (JM)}
-                              if hreg1 <> R_EAX then
-                                emit_reg_reg(A_MOV,S_L,R_EAX,hreg1);
-                            end;
-                     end
-                   else
-                     {if we did the mod by an "and", the result is in hreg1 and
-                      EDX certainly hasn't been pushed (JM)}
-                     if not(andmod) Then
-                       if popedx then
-                        {the mod was done by an (i)div (so the result is now in
-                         edx), but edx was occupied prior to the division, so
-                         move the result into a safe place (JM)}
-                         emit_reg_reg(A_MOV,S_L,R_EDX,hreg1)
-                       else
-                         Begin
-                       {Get rid of the unnecessary hreg1 if possible (same as with
-                        EAX in divn) (JM)}
-                           ungetregister32(hreg1);
-                           hreg1 := getexplicitregister32(R_EDX);
-                           if hreg1 <> R_EDX then
-                             emit_reg_reg(A_MOV,S_L,R_EDX,hreg1);;
-                         End;
-                   if popeax then
-                     emit_reg(A_POP,S_L,R_EAX);
-                   if popedx then
-                     emit_reg(A_POP,S_L,R_EDX);
-                  end;
-              If not(andmod or shrdiv) then
-               {andmod and shrdiv only use hreg1 (which is already in usedinproc,
-                since it was acquired with getregister), the others also use both
-                EAX and EDX (JM)}
-                Begin
-                  usedinproc:=usedinproc or ($80 shr byte(R_EAX));
-                  usedinproc:=usedinproc or ($80 shr byte(R_EDX));
-                End;
-              clear_location(p^.location);
-              p^.location.loc:=LOC_REGISTER;
-              p^.location.register:=hreg1;
-           end;
-      end;
-
-
-{*****************************************************************************
-                             SecondShlShr
-*****************************************************************************}
-
-    procedure secondshlshr(var p : ptree);
-      var
-         hregister1,hregister2,hregister3,
-         hregisterhigh,hregisterlow : tregister;
-         pushed,popecx : boolean;
-         op : tasmop;
-         l1,l2,l3 : pasmlabel;
-
-      begin
-         popecx:=false;
-
-         secondpass(p^.left);
-         pushed:=maybe_push(p^.right^.registers32,p^.left,is_64bitint(p^.left^.resulttype));
-         secondpass(p^.right);
-         if pushed then
-           restore(p^.left,is_64bitint(p^.left^.resulttype));
-
-         if is_64bitint(p^.left^.resulttype) then
-           begin
-              { load left operator in a register }
-              if p^.left^.location.loc<>LOC_REGISTER then
-                begin
-                   if p^.left^.location.loc=LOC_CREGISTER then
-                     begin
-                        hregisterlow:=getregister32;
-                        hregisterhigh:=getregister32;
-                        emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,
-                          hregisterlow);
-                        emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,
-                          hregisterlow);
-                     end
-                   else
-                     begin
-                        del_reference(p^.left^.location.reference);
-                        hregisterlow:=getregister32;
-                        hregisterhigh:=getregister32;
-                        emit_mov_ref_reg64(p^.left^.location.reference,
-                          hregisterlow,
-                          hregisterhigh);
-                     end;
-                end
-              else
-                begin
-                   hregisterlow:=p^.left^.location.registerlow;
-                   hregisterhigh:=p^.left^.location.registerhigh;
-                end;
-
-              { shifting by a constant directly coded: }
-              if (p^.right^.treetype=ordconstn) then
-                begin
-                   { shrd/shl works only for values <=31 !! }
-                   if p^.right^.value>31 then
-                     begin
-                        if p^.treetype=shln then
-                          begin
-                             emit_reg_reg(A_XOR,S_L,hregisterhigh,
-                               hregisterhigh);
-                             emit_const_reg(A_SHL,S_L,p^.right^.value and 31,
-                               hregisterlow);
-                          end
-                        else
-                          begin
-                             emit_reg_reg(A_XOR,S_L,hregisterlow,
-                               hregisterlow);
-                             emit_const_reg(A_SHR,S_L,p^.right^.value and 31,
-                               hregisterhigh);
-                          end;
-                        p^.location.registerhigh:=hregisterlow;
-                        p^.location.registerlow:=hregisterhigh;
-                     end
-                   else
-                     begin
-                        if p^.treetype=shln then
-                          begin
-                             emit_const_reg_reg(A_SHLD,S_L,p^.right^.value and 31,
-                               hregisterlow,hregisterhigh);
-                             emit_const_reg(A_SHL,S_L,p^.right^.value and 31,
-                               hregisterlow);
-                          end
-                        else
-                          begin
-                             emit_const_reg_reg(A_SHRD,S_L,p^.right^.value and 31,
-                               hregisterhigh,hregisterlow);
-                             emit_const_reg(A_SHR,S_L,p^.right^.value and 31,
-                               hregisterhigh);
-                          end;
-                        p^.location.registerlow:=hregisterlow;
-                        p^.location.registerhigh:=hregisterhigh;
-                     end;
-                   p^.location.loc:=LOC_REGISTER;
-                end
-              else
-                begin
-                   { load right operators in a register }
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                       if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             hregister2:=getexplicitregister32(R_ECX);
-                             emit_reg_reg(A_MOV,S_L,p^.right^.location.register,
-                               hregister2);
-                          end
-                        else
-                          begin
-                             del_reference(p^.right^.location.reference);
-                             hregister2:=getexplicitregister32(R_ECX);
-                             emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),
-                               hregister2);
-                          end;
-                     end
-                   else
-                     hregister2:=p^.right^.location.register;
-
-                   { left operator is already in a register }
-                   { hence are both in a register }
-                   { is it in the case ECX ? }
-                   if (hregisterlow=R_ECX) then
-                     begin
-                        { then only swap }
-                        emit_reg_reg(A_XCHG,S_L,hregisterlow,hregister2);
-                        hregister3:=hregisterlow;
-                        hregisterlow:=hregister2;
-                        hregister2:=hregister3;
-                     end
-                   else if (hregisterhigh=R_ECX) then
-                     begin
-                        { then only swap }
-                        emit_reg_reg(A_XCHG,S_L,hregisterhigh,hregister2);
-                        hregister3:=hregisterhigh;
-                        hregisterhigh:=hregister2;
-                        hregister2:=hregister3;
-                     end
-
-                   { if second operator not in ECX ? }
-                   else if (hregister2<>R_ECX) then
-                     begin
-                        { ECX occupied then push it }
-                        if not (R_ECX in unused) then
-                         begin
-                           popecx:=true;
-                           emit_reg(A_PUSH,S_L,R_ECX);
-                         end;
-                        emit_reg_reg(A_MOV,S_L,hregister2,R_ECX);
-                     end;
-
-                   if hregister2 <> R_ECX then
-                     ungetregister32(hregister2);
-
-                   { the damned shift instructions work only til a count of 32 }
-                   { so we've to do some tricks here                           }
-                   if p^.treetype=shln then
-                     begin
-                        getlabel(l1);
-                        getlabel(l2);
-                        getlabel(l3);
-                        emit_const_reg(A_CMP,S_L,64,R_ECX);
-                        emitjmp(C_L,l1);
-                        emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
-                        emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l1);
-                        emit_const_reg(A_CMP,S_L,32,R_ECX);
-                        emitjmp(C_L,l2);
-                        emit_const_reg(A_SUB,S_L,32,R_ECX);
-                        emit_reg_reg(A_SHL,S_L,R_CL,
-                          hregisterlow);
-                        emit_reg_reg(A_MOV,S_L,hregisterlow,hregisterhigh);
-                        emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
-                        emitjmp(C_None,l3);
-                        emitlab(l2);
-                        emit_reg_reg_reg(A_SHLD,S_L,R_CL,
-                          hregisterlow,hregisterhigh);
-                        emit_reg_reg(A_SHL,S_L,R_CL,
-                          hregisterlow);
-                        emitlab(l3);
-                     end
-                   else
-                     begin
-                        getlabel(l1);
-                        getlabel(l2);
-                        getlabel(l3);
-                        emit_const_reg(A_CMP,S_L,64,R_ECX);
-                        emitjmp(C_L,l1);
-                        emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow);
-                        emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l1);
-                        emit_const_reg(A_CMP,S_L,32,R_ECX);
-                        emitjmp(C_L,l2);
-                        emit_const_reg(A_SUB,S_L,32,R_ECX);
-                        emit_reg_reg(A_SHR,S_L,R_CL,
-                          hregisterhigh);
-                        emit_reg_reg(A_MOV,S_L,hregisterhigh,hregisterlow);
-                        emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh);
-                        emitjmp(C_None,l3);
-                        emitlab(l2);
-                        emit_reg_reg_reg(A_SHRD,S_L,R_CL,
-                          hregisterhigh,hregisterlow);
-                        emit_reg_reg(A_SHR,S_L,R_CL,
-                          hregisterhigh);
-                        emitlab(l3);
-
-                     end;
-
-                   { maybe put ECX back }
-                   if popecx then
-                     emit_reg(A_POP,S_L,R_ECX)
-                   else ungetregister32(R_ECX);
-
-                   p^.location.registerlow:=hregisterlow;
-                   p^.location.registerhigh:=hregisterhigh;
-                end;
-           end
-         else
-           begin
-              { load left operators in a register }
-              if p^.left^.location.loc<>LOC_REGISTER then
-                begin
-                   if p^.left^.location.loc=LOC_CREGISTER then
-                     begin
-                        hregister1:=getregister32;
-                        emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
-                          hregister1);
-                     end
-                   else
-                     begin
-                        del_reference(p^.left^.location.reference);
-                        hregister1:=getregister32;
-                        emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
-                          hregister1);
-                     end;
-                end
-              else
-                hregister1:=p^.left^.location.register;
-
-              { determine operator }
-              if p^.treetype=shln then
-                op:=A_SHL
-              else
-                op:=A_SHR;
-
-              { shifting by a constant directly coded: }
-              if (p^.right^.treetype=ordconstn) then
-                begin
-                   { l shl 32 should 0 imho, but neither TP nor Delphi do it in this way (FK)
-                   if p^.right^.value<=31 then
-                   }
-                     emit_const_reg(op,S_L,p^.right^.value and 31,
-                       hregister1);
-                   {
-                   else
-                     emit_reg_reg(A_XOR,S_L,hregister1,
-                       hregister1);
-                   }
-                   p^.location.loc:=LOC_REGISTER;
-                   p^.location.register:=hregister1;
-                end
-              else
-                begin
-                   { load right operators in a register }
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                       if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             hregister2:=getexplicitregister32(R_ECX);
-                             emit_reg_reg(A_MOV,S_L,p^.right^.location.register,
-                               hregister2);
-                          end
-                        else
-                          begin
-                             del_reference(p^.right^.location.reference);
-                             hregister2:=getexplicitregister32(R_ECX);
-                             emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),
-                               hregister2);
-                          end;
-                     end
-                   else
-                     hregister2:=p^.right^.location.register;
-
-                   { left operator is already in a register }
-                   { hence are both in a register }
-                   { is it in the case ECX ? }
-                   if (hregister1=R_ECX) then
-                     begin
-                        { then only swap }
-                        emit_reg_reg(A_XCHG,S_L,hregister1,hregister2);
-                        hregister3:=hregister1;
-                        hregister1:=hregister2;
-                        hregister2:=hregister3;
-                     end
-                   { if second operator not in ECX ? }
-                   else if (hregister2<>R_ECX) then
-                     begin
-                        { ECX occupied then push it }
-                        if not (R_ECX in unused) then
-                         begin
-                           popecx:=true;
-                           emit_reg(A_PUSH,S_L,R_ECX);
-                         end;
-                        emit_reg_reg(A_MOV,S_L,hregister2,R_ECX);
-                     end;
-                   ungetregister32(hregister2);
-                   { right operand is in ECX }
-                   emit_reg_reg(op,S_L,R_CL,hregister1);
-                   { maybe ECX back }
-                   if popecx then
-                     emit_reg(A_POP,S_L,R_ECX);
-                   p^.location.register:=hregister1;
-                end;
-           end;
-      end;
-
-
-{*****************************************************************************
-                             SecondUnaryMinus
-*****************************************************************************}
-
-    procedure secondunaryminus(var p : ptree);
-
-{$ifdef SUPPORT_MMX}
-      procedure do_mmx_neg;
-        var
-           op : tasmop;
-        begin
-           p^.location.loc:=LOC_MMXREGISTER;
-           if cs_mmx_saturation in aktlocalswitches then
-             case mmx_type(p^.resulttype) of
-                mmxs8bit:
-                  op:=A_PSUBSB;
-                mmxu8bit:
-                  op:=A_PSUBUSB;
-                mmxs16bit,mmxfixed16:
-                  op:=A_PSUBSW;
-                mmxu16bit:
-                  op:=A_PSUBUSW;
-             end
-           else
-             case mmx_type(p^.resulttype) of
-                mmxs8bit,mmxu8bit:
-                  op:=A_PSUBB;
-                mmxs16bit,mmxu16bit,mmxfixed16:
-                  op:=A_PSUBW;
-                mmxs32bit,mmxu32bit:
-                  op:=A_PSUBD;
-             end;
-           emit_reg_reg(op,S_NO,p^.location.register,R_MM7);
-           emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register);
-        end;
-{$endif}
-
-      begin
-         if is_64bitint(p^.left^.resulttype) then
-           begin
-              secondpass(p^.left);
-              clear_location(p^.location);
-              p^.location.loc:=LOC_REGISTER;
-              case p^.left^.location.loc of
-                LOC_REGISTER :
-                  begin
-                     p^.location.registerlow:=p^.left^.location.registerlow;
-                     p^.location.registerhigh:=p^.left^.location.registerhigh;
-                  end;
-                LOC_CREGISTER :
-                  begin
-                     p^.location.registerlow:=getregister32;
-                     p^.location.registerhigh:=getregister32;
-                     emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,p^.location.registerlow);
-                     emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,p^.location.registerhigh);
-                  end;
-                LOC_REFERENCE,LOC_MEM :
-                  begin
-                     del_reference(p^.left^.location.reference);
-                     p^.location.registerlow:=getregister32;
-                     p^.location.registerhigh:=getregister32;
-                     emit_mov_ref_reg64(p^.left^.location.reference,
-                       p^.location.registerlow,
-                       p^.location.registerhigh);
-                  end;
-              end;
-            {
-            emit_reg(A_NEG,S_L,p^.location.registerlow);
-            emit_const_reg(A_ADC,S_L,0,p^.location.registerhigh);
-            emit_reg(A_NEG,S_L,p^.location.registerhigh);
-            }
-            emit_reg(A_NOT,S_L,p^.location.registerhigh);
-            emit_reg(A_NEG,S_L,p^.location.registerlow);
-            emit_const_reg(A_SBB,S_L,-1,p^.location.registerhigh);
-           end
-         else
-           begin
-              secondpass(p^.left);
-              p^.location.loc:=LOC_REGISTER;
-              case p^.left^.location.loc of
-                 LOC_REGISTER:
-                   begin
-                      p^.location.register:=p^.left^.location.register;
-                      emit_reg(A_NEG,S_L,p^.location.register);
-                   end;
-                 LOC_CREGISTER:
-                   begin
-                      p^.location.register:=getregister32;
-                      emit_reg_reg(A_MOV,S_L,p^.location.register,
-                        p^.location.register);
-                      emit_reg(A_NEG,S_L,p^.location.register);
-                   end;
-{$ifdef SUPPORT_MMX}
-                 LOC_MMXREGISTER:
-                   begin
-                      set_location(p^.location,p^.left^.location);
-                      emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
-                      do_mmx_neg;
-                   end;
-                 LOC_CMMXREGISTER:
-                   begin
-                      p^.location.register:=getregistermmx;
-                      emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
-                      emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
-                        p^.location.register);
-                      do_mmx_neg;
-                   end;
-{$endif SUPPORT_MMX}
-                 LOC_REFERENCE,LOC_MEM:
-                                begin
-                                   del_reference(p^.left^.location.reference);
-                                   if (p^.left^.resulttype^.deftype=floatdef) and
-                                      (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
-                                     begin
-                                        p^.location.loc:=LOC_FPU;
-                                        floatload(pfloatdef(p^.left^.resulttype)^.typ,
-                                          p^.left^.location.reference);
-                                        emit_none(A_FCHS,S_NO);
-                                     end
-{$ifdef SUPPORT_MMX}
-                                   else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(p^.left^.resulttype) then
-                                     begin
-                                        p^.location.register:=getregistermmx;
-                                        emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
-                                        emit_ref_reg(A_MOVQ,S_NO,
-                                          newreference(p^.left^.location.reference),
-                                          p^.location.register);
-                                        do_mmx_neg;
-                                     end
-{$endif SUPPORT_MMX}
-                                   else
-                                     begin
-                                        p^.location.register:=getregister32;
-                                        emit_ref_reg(A_MOV,S_L,
-                                          newreference(p^.left^.location.reference),
-                                          p^.location.register);
-                                        emit_reg(A_NEG,S_L,p^.location.register);
-                                     end;
-                                end;
-                 LOC_FPU:
-                   begin
-                      p^.location.loc:=LOC_FPU;
-                      emit_none(A_FCHS,S_NO);
-                   end;
-                 LOC_CFPUREGISTER:
-                   begin
-                      emit_reg(A_FLD,S_NO,
-                        correct_fpuregister(p^.left^.location.register,fpuvaroffset));
-                      inc(fpuvaroffset);
-                      p^.location.loc:=LOC_FPU;
-                      emit_none(A_FCHS,S_NO);
-                   end;
-              end;
-           end;
-{ Here was a problem...     }
-{ Operand to be negated always     }
-{ seems to be converted to signed  }
-{ 32-bit before doing neg!!     }
-{ So this is useless...     }
-{ that's not true: -2^31 gives an overflow error if it is negaded (FK) }
-{        emitoverflowcheck(p);}
-      end;
-
-
-{*****************************************************************************
-                               SecondNot
-*****************************************************************************}
-
-    procedure secondnot(var p : ptree);
-      const
-         flagsinvers : array[F_E..F_BE] of tresflags =
-            (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
-             F_BE,F_B,F_AE,F_A);
-      var
-         hl : pasmlabel;
-         opsize : topsize;
-      begin
-         if is_boolean(p^.resulttype) then
-          begin
-            opsize:=def_opsize(p^.resulttype);
-            { the second pass could change the location of left }
-            { if it is a register variable, so we've to do      }
-            { this before the case statement                    }
-            if p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,
-              LOC_FLAGS,LOC_REGISTER,LOC_CREGISTER] then
-              secondpass(p^.left);
-            case p^.left^.location.loc of
-              LOC_JUMP :
-                begin
-                  hl:=truelabel;
-                  truelabel:=falselabel;
-                  falselabel:=hl;
-                  secondpass(p^.left);
-                  maketojumpbool(p^.left);
-                  hl:=truelabel;
-                  truelabel:=falselabel;
-                  falselabel:=hl;
-                end;
-              LOC_FLAGS :
-                p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
-              LOC_REGISTER :
-                begin
-                  {p^.location.register:=p^.left^.location.register;
-                  emit_const_reg(A_XOR,opsize,1,p^.location.register);}
-                  p^.location.loc:=LOC_FLAGS;
-                  p^.location.resflags:=F_E;
-                  emit_reg_reg(A_TEST,opsize,
-                    p^.left^.location.register,p^.left^.location.register);
-                  ungetregister(p^.left^.location.register);
-                end;
-              LOC_CREGISTER :
-                begin
-                  clear_location(p^.location);
-                  p^.location.loc:=LOC_REGISTER;
-                  p^.location.register:=def_getreg(p^.resulttype);
-                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register);
-                  emit_reg_reg(A_TEST,opsize,p^.location.register,p^.location.register);
-                  ungetregister(p^.location.register);
-                  p^.location.loc:=LOC_FLAGS;
-                  p^.location.resflags:=F_E;
-                end;
-              LOC_REFERENCE,
-              LOC_MEM :
-                begin
-                  clear_location(p^.location);
-                  p^.location.loc:=LOC_REGISTER;
-                  del_reference(p^.left^.location.reference);
-                  { this was placed before del_ref => internaalerror(10) }
-                  p^.location.register:=def_getreg(p^.resulttype);
-                  emit_ref_reg(A_MOV,opsize,
-                    newreference(p^.left^.location.reference),p^.location.register);
-                  emit_reg_reg(A_TEST,opsize,p^.location.register,p^.location.register);
-                  ungetregister(p^.location.register);
-                  p^.location.loc:=LOC_FLAGS;
-                  p^.location.resflags:=F_E;
-                end;
-            end;
-          end
-{$ifdef SUPPORT_MMX}
-         else
-          if (cs_mmx in aktlocalswitches) and is_mmx_able_array(p^.left^.resulttype) then
-           begin
-             secondpass(p^.left);
-             p^.location.loc:=LOC_MMXREGISTER;
-             { prepare EDI }
-{$ifndef noAllocEdi}
-             getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-             emit_const_reg(A_MOV,S_L,$ffffffff,R_EDI);
-             { load operand }
-             case p^.left^.location.loc of
-               LOC_MMXREGISTER:
-                 set_location(p^.location,p^.left^.location);
-               LOC_CMMXREGISTER:
-                 begin
-                   p^.location.register:=getregistermmx;
-                   emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,p^.location.register);
-                 end;
-               LOC_REFERENCE,LOC_MEM:
-                 begin
-                   del_reference(p^.left^.location.reference);
-                   p^.location.register:=getregistermmx;
-                   emit_ref_reg(A_MOVQ,S_NO,
-                     newreference(p^.left^.location.reference),p^.location.register);
-                 end;
-             end;
-             { load mask }
-             emit_reg_reg(A_MOVD,S_NO,R_EDI,R_MM7);
-{$ifndef noAllocEdi}
-             ungetregister32(R_EDI);
-{$endif noAllocEdi}
-             { lower 32 bit }
-             emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
-             { shift mask }
-             emit_const_reg(A_PSLLQ,S_NO,32,R_MM7);
-             { higher 32 bit }
-             emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
-           end
-{$endif SUPPORT_MMX}
-         else if is_64bitint(p^.left^.resulttype) then
-           begin
-              secondpass(p^.left);
-              clear_location(p^.location);
-              p^.location.loc:=LOC_REGISTER;
-              case p^.left^.location.loc of
-                LOC_REGISTER :
-                  begin
-                     p^.location.registerlow:=p^.left^.location.registerlow;
-                     p^.location.registerhigh:=p^.left^.location.registerhigh;
-                     emit_reg(A_NOT,S_L,p^.location.registerlow);
-                     emit_reg(A_NOT,S_L,p^.location.registerhigh);
-                  end;
-                LOC_CREGISTER :
-                  begin
-                     p^.location.registerlow:=getregister32;
-                     p^.location.registerhigh:=getregister32;
-                     emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,p^.location.registerlow);
-                     emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,p^.location.registerhigh);
-                     emit_reg(A_NOT,S_L,p^.location.registerlow);
-                     emit_reg(A_NOT,S_L,p^.location.registerhigh);
-                  end;
-                LOC_REFERENCE,LOC_MEM :
-                  begin
-                     del_reference(p^.left^.location.reference);
-                     p^.location.registerlow:=getregister32;
-                     p^.location.registerhigh:=getregister32;
-                     emit_mov_ref_reg64(p^.left^.location.reference,
-                       p^.location.registerlow,
-                       p^.location.registerhigh);
-                     emit_reg(A_NOT,S_L,p^.location.registerlow);
-                     emit_reg(A_NOT,S_L,p^.location.registerhigh);
-                  end;
-              end;
-           end
-         else
-          begin
-            secondpass(p^.left);
-            clear_location(p^.location);
-            p^.location.loc:=LOC_REGISTER;
-            case p^.left^.location.loc of
-              LOC_REGISTER :
-                begin
-                  p^.location.register:=p^.left^.location.register;
-                  emit_reg(A_NOT,S_L,p^.location.register);
-                end;
-              LOC_CREGISTER :
-                begin
-                  p^.location.register:=getregister32;
-                  emit_reg_reg(A_MOV,S_L,p^.left^.location.register,p^.location.register);
-                  emit_reg(A_NOT,S_L,p^.location.register);
-                end;
-              LOC_REFERENCE,LOC_MEM :
-                begin
-                  del_reference(p^.left^.location.reference);
-                  p^.location.register:=getregister32;
-                  emit_ref_reg(A_MOV,S_L,
-                    newreference(p^.left^.location.reference),p^.location.register);
-                  emit_reg(A_NOT,S_L,p^.location.register);
-                end;
-            end;
-          end;
-      end;
-
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.7  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.6  2000/09/18 10:15:48  jonas
-    * fixed bug in flagsinvers array for unsigned flags (fixed web bug
-      1139, not 1135 like I mentioned in the fixes branch) (merged from fixes)
-
-  Revision 1.5  2000/08/27 16:11:49  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.4  2000/07/28 13:28:25  jonas
-    * fixed bug in secondshlshr where ecx was released too soon in some
-      cases causing a combination of -Or and -dnewoptimizations to generate
-      wrong code
-      (merged from fixes branch and since in 1.1 -dnewoptimizations has
-      been released, it always generated wrong code here when using -O2 or
-      higher)
-
-  Revision 1.3  2000/07/14 05:11:48  michael
-  + Patch to 1.1
-
-  Revision 1.2  2000/07/13 11:32:35  michael
-  + removed logs
-
-}

compiler/old/cg386mem.pas

@@ -1,994 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for in memory related nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386mem;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondloadvmt(var p : ptree);
-    procedure secondhnewn(var p : ptree);
-    procedure secondnewn(var p : ptree);
-    procedure secondhdisposen(var p : ptree);
-    procedure secondsimplenewdispose(var p : ptree);
-    procedure secondaddr(var p : ptree);
-    procedure seconddoubleaddr(var p : ptree);
-    procedure secondderef(var p : ptree);
-    procedure secondsubscriptn(var p : ptree);
-    procedure secondvecn(var p : ptree);
-    procedure secondselfn(var p : ptree);
-    procedure secondwith(var p : ptree);
-
-
-implementation
-
-    uses
-{$ifdef delphi}
-      sysutils,
-{$else}
-      strings,
-{$endif}
-{$ifdef GDB}
-      gdb,
-{$endif GDB}
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,pass_1,
-      cpubase,cpuasm,
-      cgai386,tgeni386;
-
-{*****************************************************************************
-                             SecondLoadVMT
-*****************************************************************************}
-
-    procedure secondloadvmt(var p : ptree);
-      begin
-         p^.location.register:=getregister32;
-         emit_sym_ofs_reg(A_MOV,
-            S_L,newasmsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.pointertype.def)^.vmt_mangledname),0,
-            p^.location.register);
-      end;
-
-
-{*****************************************************************************
-                             SecondHNewN
-*****************************************************************************}
-
-    procedure secondhnewn(var p : ptree);
-      begin
-      end;
-
-
-{*****************************************************************************
-                             SecondNewN
-*****************************************************************************}
-
-    procedure secondnewn(var p : ptree);
-      var
-         pushed : tpushed;
-         r : preference;
-      begin
-         if assigned(p^.left) then
-           begin
-              secondpass(p^.left);
-              p^.location.register:=p^.left^.location.register;
-           end
-         else
-           begin
-              pushusedregisters(pushed,$ff);
-
-              gettempofsizereference(target_os.size_of_pointer,p^.location.reference);
-
-              { determines the size of the mem block }
-              push_int(ppointerdef(p^.resulttype)^.pointertype.def^.size);
-              emit_push_lea_loc(p^.location,false);
-              emitcall('FPC_GETMEM');
-
-              if ppointerdef(p^.resulttype)^.pointertype.def^.needs_inittable then
-                begin
-                   new(r);
-                   reset_reference(r^);
-                   r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label;
-                   emitpushreferenceaddr(r^);
-                   dispose(r);
-                   { push pointer we just allocated, we need to initialize the
-                     data located at that pointer not the pointer self (PFV) }
-                   emit_push_loc(p^.location);
-                   emitcall('FPC_INITIALIZE');
-                end;
-              popusedregisters(pushed);
-              { may be load ESI }
-              maybe_loadesi;
-           end;
-         if codegenerror then
-           exit;
-      end;
-
-
-{*****************************************************************************
-                             SecondDisposeN
-*****************************************************************************}
-
-    procedure secondhdisposen(var p : ptree);
-      begin
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-         reset_reference(p^.location.reference);
-         case p^.left^.location.loc of
-            LOC_REGISTER:
-              p^.location.reference.index:=p^.left^.location.register;
-            LOC_CREGISTER:
-              begin
-                 p^.location.reference.index:=getregister32;
-                 emit_reg_reg(A_MOV,S_L,
-                   p^.left^.location.register,
-                   p^.location.reference.index);
-              end;
-            LOC_MEM,LOC_REFERENCE :
-              begin
-                 del_reference(p^.left^.location.reference);
-                 p^.location.reference.index:=getregister32;
-                 emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
-                   p^.location.reference.index);
-              end;
-         end;
-      end;
-
-
-{*****************************************************************************
-                             SecondNewDispose
-*****************************************************************************}
-
-    procedure secondsimplenewdispose(var p : ptree);
-
-      var
-         pushed : tpushed;
-         r : preference;
-
-      begin
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-
-         pushusedregisters(pushed,$ff);
-
-         { call the mem handling procedures }
-         case p^.treetype of
-           simpledisposen:
-             begin
-                if ppointerdef(p^.left^.resulttype)^.pointertype.def^.needs_inittable then
-                  begin
-                     new(r);
-                     reset_reference(r^);
-                     r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label;
-                     emitpushreferenceaddr(r^);
-                     dispose(r);
-                     { push pointer adress }
-                     emit_push_loc(p^.left^.location);
-                     emitcall('FPC_FINALIZE');
-                  end;
-                emit_push_lea_loc(p^.left^.location,true);
-                emitcall('FPC_FREEMEM');
-             end;
-           simplenewn:
-             begin
-                { determines the size of the mem block }
-                push_int(ppointerdef(p^.left^.resulttype)^.pointertype.def^.size);
-                emit_push_lea_loc(p^.left^.location,true);
-                emitcall('FPC_GETMEM');
-                if ppointerdef(p^.left^.resulttype)^.pointertype.def^.needs_inittable then
-                  begin
-                     new(r);
-                     reset_reference(r^);
-                     r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label;
-                     emitpushreferenceaddr(r^);
-                     dispose(r);
-                     emit_push_loc(p^.left^.location);
-                     emitcall('FPC_INITIALIZE');
-                  end;
-             end;
-         end;
-         popusedregisters(pushed);
-         { may be load ESI }
-         maybe_loadesi;
-      end;
-
-
-{*****************************************************************************
-                             SecondAddr
-*****************************************************************************}
-
-    procedure secondaddr(var p : ptree);
-      begin
-         secondpass(p^.left);
-
-         { when loading procvar we do nothing with this node, so load the
-           location of left }
-         if p^.procvarload then
-          begin
-            set_location(p^.location,p^.left^.location);
-            exit;
-          end;
-
-         p^.location.loc:=LOC_REGISTER;
-         del_reference(p^.left^.location.reference);
-         p^.location.register:=getregister32;
-         {@ on a procvar means returning an address to the procedure that
-           is stored in it.}
-         { yes but p^.left^.symtableentry can be nil
-           for example on @self !! }
-         { symtableentry can be also invalid, if left is no tree node }
-         if (m_tp_procvar in aktmodeswitches) and
-           (p^.left^.treetype=loadn) and
-           assigned(p^.left^.symtableentry) and
-           (p^.left^.symtableentry^.typ=varsym) and
-           (pvarsym(p^.left^.symtableentry)^.vartype.def^.deftype=procvardef) then
-           emit_ref_reg(A_MOV,S_L,
-             newreference(p^.left^.location.reference),
-             p^.location.register)
-         else
-           emit_ref_reg(A_LEA,S_L,
-             newreference(p^.left^.location.reference),
-             p^.location.register);
-           { for use of other segments }
-           if p^.left^.location.reference.segment<>R_NO then
-             p^.location.segment:=p^.left^.location.reference.segment;
-      end;
-
-
-{*****************************************************************************
-                             SecondDoubleAddr
-*****************************************************************************}
-
-    procedure seconddoubleaddr(var p : ptree);
-      begin
-         secondpass(p^.left);
-         p^.location.loc:=LOC_REGISTER;
-         del_reference(p^.left^.location.reference);
-         p^.location.register:=getregister32;
-         emit_ref_reg(A_LEA,S_L,
-         newreference(p^.left^.location.reference),
-           p^.location.register);
-      end;
-
-
-{*****************************************************************************
-                             SecondDeRef
-*****************************************************************************}
-
-    procedure secondderef(var p : ptree);
-      var
-         hr : tregister;
-      begin
-         secondpass(p^.left);
-         reset_reference(p^.location.reference);
-         case p^.left^.location.loc of
-            LOC_REGISTER:
-              p^.location.reference.base:=p^.left^.location.register;
-            LOC_CREGISTER:
-              begin
-                 { ... and reserve one for the pointer }
-                 hr:=getregister32;
-                 emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
-                 p^.location.reference.base:=hr;
-              end;
-            else
-              begin
-                 { free register }
-                 del_reference(p^.left^.location.reference);
-
-                 { ...and reserve one for the pointer }
-                 hr:=getregister32;
-                 emit_ref_reg(
-                   A_MOV,S_L,newreference(p^.left^.location.reference),
-                   hr);
-                 p^.location.reference.base:=hr;
-              end;
-         end;
-         if ppointerdef(p^.left^.resulttype)^.is_far then
-          p^.location.reference.segment:=R_FS;
-         if not ppointerdef(p^.left^.resulttype)^.is_far and
-            (cs_gdb_heaptrc in aktglobalswitches) and
-            (cs_checkpointer in aktglobalswitches) then
-              begin
-                 emit_reg(
-                   A_PUSH,S_L,p^.location.reference.base);
-                 emitcall('FPC_CHECKPOINTER');
-              end;
-      end;
-
-
-{*****************************************************************************
-                             SecondSubScriptN
-*****************************************************************************}
-
-    procedure secondsubscriptn(var p : ptree);
-      var
-         hr : tregister;
-      begin
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-         { classes must be dereferenced implicit }
-         if (p^.left^.resulttype^.deftype=objectdef) and
-           pobjectdef(p^.left^.resulttype)^.is_class then
-           begin
-             reset_reference(p^.location.reference);
-             case p^.left^.location.loc of
-                LOC_REGISTER:
-                  p^.location.reference.base:=p^.left^.location.register;
-                LOC_CREGISTER:
-                  begin
-                     { ... and reserve one for the pointer }
-                     hr:=getregister32;
-                     emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
-                       p^.location.reference.base:=hr;
-                  end;
-                else
-                  begin
-                     { free register }
-                     del_reference(p^.left^.location.reference);
-
-                     { ... and reserve one for the pointer }
-                     hr:=getregister32;
-                     emit_ref_reg(
-                       A_MOV,S_L,newreference(p^.left^.location.reference),
-                       hr);
-                     p^.location.reference.base:=hr;
-                  end;
-             end;
-           end
-         else
-           set_location(p^.location,p^.left^.location);
-
-         inc(p^.location.reference.offset,p^.vs^.address);
-      end;
-
-
-{*****************************************************************************
-                               SecondVecN
-*****************************************************************************}
-
-    procedure secondvecn(var p : ptree);
-      var
-        is_pushed : boolean;
-        ind,hr : tregister;
-        _p : ptree;
-
-          function get_mul_size:longint;
-          begin
-            if p^.memindex then
-             get_mul_size:=1
-            else
-             begin
-               if (p^.left^.resulttype^.deftype=arraydef) then
-                get_mul_size:=parraydef(p^.left^.resulttype)^.elesize
-               else
-                get_mul_size:=p^.resulttype^.size;
-             end
-          end;
-
-          procedure calc_emit_mul;
-          var
-             l1,l2 : longint;
-          begin
-            l1:=get_mul_size;
-            case l1 of
-             1,2,4,8 : p^.location.reference.scalefactor:=l1;
-            else
-              begin
-                 if ispowerof2(l1,l2) then
-                   emit_const_reg(A_SHL,S_L,l2,ind)
-                 else
-                   emit_const_reg(A_IMUL,S_L,l1,ind);
-              end;
-            end;
-          end;
-
-      var
-         extraoffset : longint;
-         { rl stores the resulttype of the left node, this is necessary }
-         { to detect if it is an ansistring                          }
-         { because in constant nodes which constant index              }
-         { the left tree is removed                                  }
-         t   : ptree;
-         hp  : preference;
-         href : treference;
-         tai : Paicpu;
-         pushed : tpushed;
-         hightree : ptree;
-         hl,otl,ofl : pasmlabel;
-      begin
-         secondpass(p^.left);
-         { we load the array reference to p^.location }
-
-         { an ansistring needs to be dereferenced }
-         if is_ansistring(p^.left^.resulttype) or
-           is_widestring(p^.left^.resulttype) then
-           begin
-              reset_reference(p^.location.reference);
-              if p^.callunique then
-                begin
-                   if p^.left^.location.loc<>LOC_REFERENCE then
-                     begin
-                        CGMessage(cg_e_illegal_expression);
-                        exit;
-                     end;
-                   pushusedregisters(pushed,$ff);
-                   emitpushreferenceaddr(p^.left^.location.reference);
-                   if is_ansistring(p^.left^.resulttype) then
-                     emitcall('FPC_ANSISTR_UNIQUE')
-                   else
-                     emitcall('FPC_WIDESTR_UNIQUE');
-                   maybe_loadesi;
-                   popusedregisters(pushed);
-                end;
-
-              if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-                begin
-                   p^.location.reference.base:=p^.left^.location.register;
-                end
-              else
-                begin
-                   del_reference(p^.left^.location.reference);
-                   p^.location.reference.base:=getregister32;
-                   emit_ref_reg(A_MOV,S_L,
-                     newreference(p^.left^.location.reference),
-                     p^.location.reference.base);
-                end;
-
-              { check for a zero length string,
-                we can use the ansistring routine here }
-              if (cs_check_range in aktlocalswitches) then
-                begin
-                   pushusedregisters(pushed,$ff);
-                   emit_reg(A_PUSH,S_L,p^.location.reference.base);
-                   emitcall('FPC_ANSISTR_CHECKZERO');
-                   maybe_loadesi;
-                   popusedregisters(pushed);
-                end;
-
-              if is_ansistring(p^.left^.resulttype) then
-                { in ansistrings S[1] is pchar(S)[0] !! }
-                dec(p^.location.reference.offset)
-              else
-                begin
-                   { in widestrings S[1] is pwchar(S)[0] !! }
-                   dec(p^.location.reference.offset,2);
-                   emit_const_reg(A_SHL,S_L,
-                     1,p^.location.reference.base);
-                end;
-
-              { we've also to keep left up-to-date, because it is used   }
-              { if a constant array index occurs, subject to change (FK) }
-              set_location(p^.left^.location,p^.location);
-           end
-         else
-           set_location(p^.location,p^.left^.location);
-
-         { offset can only differ from 0 if arraydef }
-         if p^.left^.resulttype^.deftype=arraydef then
-           dec(p^.location.reference.offset,
-               get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
-         if p^.right^.treetype=ordconstn then
-           begin
-              { offset can only differ from 0 if arraydef }
-              if (p^.left^.resulttype^.deftype=arraydef) then
-                begin
-                   if not(is_open_array(p^.left^.resulttype)) and
-                      not(is_array_of_const(p^.left^.resulttype)) then
-                     begin
-                        if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
-                           (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
-                           begin
-                              if (cs_check_range in aktlocalswitches) then
-                                CGMessage(parser_e_range_check_error)
-                              else
-                                CGMessage(parser_w_range_check_error);
-                           end;
-                        dec(p^.left^.location.reference.offset,
-                            get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
-                     end
-                   else
-                     begin
-                        { range checking for open arrays !!!! }
-                        {!!!!!!!!!!!!!!!!!}
-                     end;
-                end
-              else if (p^.left^.resulttype^.deftype=stringdef) then
-                begin
-                   if (p^.right^.value=0) and not(is_shortstring(p^.left^.resulttype)) then
-                     CGMessage(cg_e_can_access_element_zero);
-
-                   if (cs_check_range in aktlocalswitches) then
-                     case pstringdef(p^.left^.resulttype)^.string_typ of
-                        { it's the same for ansi- and wide strings }
-                        st_widestring,
-                        st_ansistring:
-                          begin
-                             pushusedregisters(pushed,$ff);
-                             push_int(p^.right^.value);
-                             hp:=newreference(p^.location.reference);
-                             dec(hp^.offset,7);
-                             emit_ref(A_PUSH,S_L,hp);
-                             emitcall('FPC_ANSISTR_RANGECHECK');
-                             popusedregisters(pushed);
-                             maybe_loadesi;
-                          end;
-
-                        st_shortstring:
-                          begin
-                             {!!!!!!!!!!!!!!!!!}
-                          end;
-
-                        st_longstring:
-                          begin
-                             {!!!!!!!!!!!!!!!!!}
-                          end;
-                     end;
-                end;
-
-              inc(p^.left^.location.reference.offset,
-                  get_mul_size*p^.right^.value);
-              if p^.memseg then
-                p^.left^.location.reference.segment:=R_FS;
-              p^.left^.resulttype:=p^.resulttype;
-              disposetree(p^.right);
-              _p:=p^.left;
-              putnode(p);
-              p:=_p;
-           end
-         else
-         { not treetype=ordconstn }
-           begin
-              { quick hack, to overcome Delphi 2 }
-              if (cs_regalloc in aktglobalswitches) and
-              { if we do range checking, we don't }
-              { need that fancy code (it would be }
-              { buggy)                            }
-                not(cs_check_range in aktlocalswitches) and
-                (p^.left^.resulttype^.deftype=arraydef) then
-                begin
-                   extraoffset:=0;
-                   if (p^.right^.treetype=addn) then
-                     begin
-                        if p^.right^.right^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.right^.value;
-                             t:=p^.right^.left;
-                             { First pass processed this with the assumption   }
-                             { that there was an add node which may require an }
-                             { extra register. Fake it or die with IE10 (JM)   }
-                             t^.registers32 :=  p^.right^.registers32;
-                             putnode(p^.right^.right);
-                             putnode(p^.right);
-                             p^.right:=t;
-                          end
-                        else if p^.right^.left^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.left^.value;
-                             t:=p^.right^.right;
-                             t^.registers32 :=  p^.right^.registers32;
-                             putnode(p^.right^.left);
-                             putnode(p^.right);
-                             p^.right:=t;
-                          end;
-                     end
-                   else if (p^.right^.treetype=subn) then
-                     begin
-                        if p^.right^.right^.treetype=ordconstn then
-                          begin
-{ this was "extraoffset:=p^.right^.right^.value;" Looks a bit like
-  copy-paste bug :) (JM) }
-                             extraoffset:=-p^.right^.right^.value;
-                             t:=p^.right^.left;
-                             t^.registers32 :=  p^.right^.registers32;
-                             putnode(p^.right^.right);
-                             putnode(p^.right);
-                             p^.right:=t;
-                          end
-{ You also have to negate p^.right^.right in this case! I can't add an
-  unaryminusn without causing a crash, so I've disabled it (JM)
-                        else if p^.right^.left^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.left^.value;
-                             t:=p^.right^.right;
-                             t^.registers32 :=  p^.right^.registers32;
-                             putnode(p^.right);
-                             putnode(p^.right^.left);
-                             p^.right:=t;
-                         end;}
-                     end;
-                   inc(p^.location.reference.offset,
-                       get_mul_size*extraoffset);
-                end;
-              { calculate from left to right }
-              if (p^.location.loc<>LOC_REFERENCE) and
-                 (p^.location.loc<>LOC_MEM) then
-                CGMessage(cg_e_illegal_expression);
-              if (p^.right^.location.loc=LOC_JUMP) then
-               begin
-                 otl:=truelabel;
-                 getlabel(truelabel);
-                 ofl:=falselabel;
-                 getlabel(falselabel);
-               end;
-              is_pushed:=maybe_push(p^.right^.registers32,p,false);
-              secondpass(p^.right);
-              if is_pushed then
-                restore(p,false);
-              { here we change the location of p^.right
-                and the update was forgotten so it
-                led to wrong code in emitrangecheck later PM
-                so make range check before }
-
-              if cs_check_range in aktlocalswitches then
-               begin
-                 if p^.left^.resulttype^.deftype=arraydef then
-                   begin
-                     if is_open_array(p^.left^.resulttype) or
-                        is_array_of_const(p^.left^.resulttype) then
-                      begin
-                        reset_reference(href);
-                        parraydef(p^.left^.resulttype)^.genrangecheck;
-                        href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring);
-                        href.offset:=4;
-                        getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                        hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable);
-                        firstpass(hightree);
-                        secondpass(hightree);
-                        emit_mov_loc_ref(hightree^.location,href,S_L,true);
-                        disposetree(hightree);
-                      end;
-                     emitrangecheck(p^.right,p^.left^.resulttype);
-                   end;
-               end;
-
-              case p^.right^.location.loc of
-                 LOC_REGISTER:
-                   begin
-                      ind:=p^.right^.location.register;
-                      case p^.right^.resulttype^.size of
-                         1:
-                           begin
-                              hr:=reg8toreg32(ind);
-                              emit_reg_reg(A_MOVZX,S_BL,ind,hr);
-                              ind:=hr;
-                           end;
-                         2:
-                           begin
-                              hr:=reg16toreg32(ind);
-                              emit_reg_reg(A_MOVZX,S_WL,ind,hr);
-                              ind:=hr;
-                           end;
-                      end;
-                   end;
-                 LOC_CREGISTER:
-                   begin
-                      ind:=getregister32;
-                      case p^.right^.resulttype^.size of
-                         1:
-                           emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
-                         2:
-                           emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
-                         4:
-                           emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
-                      end;
-                   end;
-                 LOC_FLAGS:
-                   begin
-                      ind:=getregister32;
-                      emit_flag2reg(p^.right^.location.resflags,reg32toreg8(ind));
-                      emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
-                   end;
-                 LOC_JUMP :
-                   begin
-                     ind:=getregister32;
-                     emitlab(truelabel);
-                     truelabel:=otl;
-                     emit_const_reg(A_MOV,S_L,1,ind);
-                     getlabel(hl);
-                     emitjmp(C_None,hl);
-                     emitlab(falselabel);
-                     falselabel:=ofl;
-                     emit_reg_reg(A_XOR,S_L,ind,ind);
-                     emitlab(hl);
-                   end;
-                 LOC_REFERENCE,LOC_MEM :
-                   begin
-                      del_reference(p^.right^.location.reference);
-                      ind:=getregister32;
-                      { Booleans are stored in an 8 bit memory location, so
-                        the use of MOVL is not correct }
-                      case p^.right^.resulttype^.size of
-                       1 : tai:=new(paicpu,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
-                       2 : tai:=new(Paicpu,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
-                       4 : tai:=new(Paicpu,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
-                      end;
-                      exprasmlist^.concat(tai);
-                   end;
-                 else
-                   internalerror(5913428);
-                end;
-
-            { produce possible range check code: }
-              if cs_check_range in aktlocalswitches then
-               begin
-                 if p^.left^.resulttype^.deftype=arraydef then
-                   begin
-                     { done defore (PM) }
-                   end
-                 else if (p^.left^.resulttype^.deftype=stringdef) then
-                   begin
-                      case pstringdef(p^.left^.resulttype)^.string_typ of
-                         { it's the same for ansi- and wide strings }
-                         st_widestring,
-                         st_ansistring:
-                           begin
-                              pushusedregisters(pushed,$ff);
-                              emit_reg(A_PUSH,S_L,ind);
-                              hp:=newreference(p^.location.reference);
-                              dec(hp^.offset,7);
-                              emit_ref(A_PUSH,S_L,hp);
-                              emitcall('FPC_ANSISTR_RANGECHECK');
-                              popusedregisters(pushed);
-                              maybe_loadesi;
-                           end;
-                         st_shortstring:
-                           begin
-                              {!!!!!!!!!!!!!!!!!}
-                           end;
-                         st_longstring:
-                           begin
-                              {!!!!!!!!!!!!!!!!!}
-                           end;
-                      end;
-                   end;
-               end;
-
-              if p^.location.reference.index=R_NO then
-               begin
-                 p^.location.reference.index:=ind;
-                 calc_emit_mul;
-               end
-              else
-               begin
-                 if p^.location.reference.base=R_NO then
-                  begin
-                    case p^.location.reference.scalefactor of
-                     2 : emit_const_reg(A_SHL,S_L,1,p^.location.reference.index);
-                     4 : emit_const_reg(A_SHL,S_L,2,p^.location.reference.index);
-                     8 : emit_const_reg(A_SHL,S_L,3,p^.location.reference.index);
-                    end;
-                    calc_emit_mul;
-                    p^.location.reference.base:=p^.location.reference.index;
-                    p^.location.reference.index:=ind;
-                  end
-                 else
-                  begin
-                    emit_ref_reg(
-                      A_LEA,S_L,newreference(p^.location.reference),
-                      p^.location.reference.index);
-                    ungetregister32(p^.location.reference.base);
-                    { the symbol offset is loaded,             }
-                    { so release the symbol name and set symbol  }
-                    { to nil                                 }
-                    p^.location.reference.symbol:=nil;
-                    p^.location.reference.offset:=0;
-                    calc_emit_mul;
-                    p^.location.reference.base:=p^.location.reference.index;
-                    p^.location.reference.index:=ind;
-                  end;
-               end;
-
-              if p^.memseg then
-                p^.location.reference.segment:=R_FS;
-           end;
-      end;
-
-{*****************************************************************************
-                               SecondSelfN
-*****************************************************************************}
-
-    procedure secondselfn(var p : ptree);
-      begin
-         reset_reference(p^.location.reference);
-         getexplicitregister32(R_ESI);
-         if (p^.resulttype^.deftype=classrefdef) or
-           ((p^.resulttype^.deftype=objectdef)
-             and pobjectdef(p^.resulttype)^.is_class
-           ) then
-           p^.location.register:=R_ESI
-         else
-           p^.location.reference.base:=R_ESI;
-      end;
-
-
-{*****************************************************************************
-                               SecondWithN
-*****************************************************************************}
-
-    procedure secondwith(var p : ptree);
-      var
-        usetemp,with_expr_in_temp : boolean;
-{$ifdef GDB}
-        withstartlabel,withendlabel : pasmlabel;
-        pp : pchar;
-        mangled_length  : longint;
-
-      const
-        withlevel : longint = 0;
-{$endif GDB}
-      begin
-         if assigned(p^.left) then
-            begin
-               secondpass(p^.left);
-               if p^.left^.location.reference.segment<>R_NO then
-                 message(parser_e_no_with_for_variable_in_other_segments);
-
-               new(p^.withreference);
-
-               usetemp:=false;
-               if (p^.left^.treetype=loadn) and
-                  (p^.left^.symtable=aktprocsym^.definition^.localst) then
-                 begin
-                    { for locals use the local storage }
-                    p^.withreference^:=p^.left^.location.reference;
-                    p^.islocal:=true;
-                 end
-               else
-                { call can have happend with a property }
-                if (p^.left^.resulttype^.deftype=objectdef) and
-                   pobjectdef(p^.left^.resulttype)^.is_class then
-                 begin
-{$ifndef noAllocEdi}
-                    getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                    emit_mov_loc_reg(p^.left^.location,R_EDI);
-                    usetemp:=true;
-                 end
-               else
-                 begin
-{$ifndef noAllocEdi}
-                   getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                   emit_lea_loc_reg(p^.left^.location,R_EDI,false);
-                   usetemp:=true;
-                 end;
-
-               release_loc(p^.left^.location);
-
-               { if the with expression is stored in a temp    }
-               { area we must make it persistent and shouldn't }
-               { release it (FK)                               }
-               if (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
-                 istemp(p^.left^.location.reference) then
-                 begin
-                    normaltemptopersistant(p^.left^.location.reference.offset);
-                    with_expr_in_temp:=true;
-                 end
-               else
-                 with_expr_in_temp:=false;
-
-               { if usetemp is set the value must be in %edi }
-               if usetemp then
-                begin
-                  gettempofsizereference(4,p^.withreference^);
-                  normaltemptopersistant(p^.withreference^.offset);
-                  { move to temp reference }
-                  emit_reg_ref(A_MOV,S_L,R_EDI,newreference(p^.withreference^));
-{$ifndef noAllocEdi}
-                  ungetregister32(R_EDI);
-{$endif noAllocEdi}
-{$ifdef GDB}
-                  if (cs_debuginfo in aktmoduleswitches) then
-                    begin
-                      inc(withlevel);
-                      getaddrlabel(withstartlabel);
-                      getaddrlabel(withendlabel);
-                      emitlab(withstartlabel);
-                      withdebuglist^.concat(new(pai_stabs,init(strpnew(
-                         '"with'+tostr(withlevel)+':'+tostr(symtablestack^.getnewtypecount)+
-                         '=*'+p^.left^.resulttype^.numberstring+'",'+
-                         tostr(N_LSYM)+',0,0,'+tostr(p^.withreference^.offset)))));
-                      mangled_length:=length(aktprocsym^.definition^.mangledname);
-                      getmem(pp,mangled_length+50);
-                      strpcopy(pp,'192,0,0,'+withstartlabel^.name);
-                      if (target_os.use_function_relative_addresses) then
-                        begin
-                          strpcopy(strend(pp),'-');
-                          strpcopy(strend(pp),aktprocsym^.definition^.mangledname);
-                        end;
-                      withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
-                    end;
-{$endif GDB}
-                  del_reference(p^.left^.location.reference);
-                end;
-
-               { p^.right can be optimize out !!! }
-               if assigned(p^.right) then
-                 secondpass(p^.right);
-
-               if usetemp then
-                 begin
-                   ungetpersistanttemp(p^.withreference^.offset);
-{$ifdef GDB}
-                   if (cs_debuginfo in aktmoduleswitches) then
-                     begin
-                       emitlab(withendlabel);
-                       strpcopy(pp,'224,0,0,'+withendlabel^.name);
-                      if (target_os.use_function_relative_addresses) then
-                        begin
-                          strpcopy(strend(pp),'-');
-                          strpcopy(strend(pp),aktprocsym^.definition^.mangledname);
-                        end;
-                       withdebuglist^.concat(new(pai_stabn,init(strnew(pp))));
-                       freemem(pp,mangled_length+50);
-                       dec(withlevel);
-                     end;
-{$endif GDB}
-                 end;
-
-               if with_expr_in_temp then
-                 ungetpersistanttemp(p^.left^.location.reference.offset);
-
-               dispose(p^.withreference);
-               p^.withreference:=nil;
-            end;
-       end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.7  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.6  2000/08/27 16:11:49  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.5  2000/07/28 07:38:13  jonas
-    * refined previous fix (sometimes the number of necessary registers was
-      overestimated) (merged from fixes branch)
-
-  Revision 1.4  2000/07/27 12:41:54  jonas
-    * fixed internalerror(10) when using -Or and complex arrays (merged
-      from fixes branch)
-
-  Revision 1.3  2000/07/21 15:14:02  jonas
-    + added is_addr field for labels, if they are only used for getting the address
-       (e.g. for io checks) and corresponding getaddrlabel() procedure
-
-  Revision 1.2  2000/07/13 11:32:35  michael
-  + removed logs
-
-}

compiler/old/cg386set.pas

@@ -1,1088 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate i386 assembler for in set/case nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg386set;
-
-{$i defines.inc}
-
-{$ifdef delphi}
-  {$O-}
-{$endif}
-
-interface
-
-    uses
-      tree;
-
-    procedure secondsetelement(var p : ptree);
-    procedure secondin(var p : ptree);
-    procedure secondcase(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,cpuinfo,
-      cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cpuasm,
-      cgai386,tgeni386;
-
-     const
-       bytes2Sxx:array[1..8] of Topsize=(S_B,S_W,S_NO,S_L,S_NO,S_NO,S_NO,S_Q);
-
-{*****************************************************************************
-                              SecondSetElement
-*****************************************************************************}
-
-    procedure secondsetelement(var p : ptree);
-       begin
-       { load first value in 32bit register }
-         secondpass(p^.left);
-         if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-           emit_to_reg32(p^.left^.location.register);
-
-       { also a second value ? }
-         if assigned(p^.right) then
-           begin
-             secondpass(p^.right);
-             if p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-              emit_to_reg32(p^.right^.location.register);
-           end;
-
-         { we doesn't modify the left side, we check only the type }
-         set_location(p^.location,p^.left^.location);
-       end;
-
-
-{*****************************************************************************
-                              SecondIn
-*****************************************************************************}
-
-    procedure secondin(var p : ptree);
-       type
-         Tsetpart=record
-           range : boolean;      {Part is a range.}
-           start,stop : byte;    {Start/stop when range; Stop=element when an element.}
-         end;
-       var
-         genjumps,
-         use_small,
-         pushed,
-         ranges     : boolean;
-         hr,hr2,
-         pleftreg   : tregister;
-         opsize     : topsize;
-         setparts   : array[1..8] of Tsetpart;
-         i,numparts : byte;
-         {href,href2 : Treference;}
-         l,l2       : pasmlabel;
-{$ifdef CORRECT_SET_IN_FPC}
-         AM         : tasmop;
-{$endif CORRECT_SET_IN_FPC}
-
-         function analizeset(Aset:pconstset;is_small:boolean):boolean;
-           type
-             byteset=set of byte;
-           var
-             compares,maxcompares:word;
-             i:byte;
-           begin
-             analizeset:=false;
-             ranges:=false;
-             numparts:=0;
-             compares:=0;
-             { Lots of comparisions take a lot of time, so do not allow
-               too much comparisions. 8 comparisions are, however, still
-               smalller than emitting the set }
-             if cs_littlesize in aktglobalswitches then
-              maxcompares:=8
-             else
-              maxcompares:=5;
-             { when smallset is possible allow only 3 compares the smallset
-               code is for littlesize also smaller when more compares are used }
-             if is_small then
-              maxcompares:=3;
-             for i:=0 to 255 do
-              if i in byteset(Aset^) then
-               begin
-                 if (numparts=0) or (i<>setparts[numparts].stop+1) then
-                  begin
-                  {Set element is a separate element.}
-                    inc(compares);
-                    if compares>maxcompares then
-                         exit;
-                    inc(numparts);
-                    setparts[numparts].range:=false;
-                    setparts[numparts].stop:=i;
-                  end
-                 else
-                  {Set element is part of a range.}
-                  if not setparts[numparts].range then
-                   begin
-                     {Transform an element into a range.}
-                     setparts[numparts].range:=true;
-                     setparts[numparts].start:=setparts[numparts].stop;
-                     setparts[numparts].stop:=i;
-                     inc(compares);
-                     if compares>maxcompares then
-                      exit;
-                   end
-                 else
-                  begin
-                    {Extend a range.}
-                    setparts[numparts].stop:=i;
-                    {A range of two elements can better
-                     be checked as two separate ones.
-                     When extending a range, our range
-                     becomes larger than two elements.}
-                    ranges:=true;
-                  end;
-              end;
-             analizeset:=true;
-           end;
-
-       begin
-         { We check first if we can generate jumps, this can be done
-           because the resulttype is already set in firstpass }
-
-         { check if we can use smallset operation using btl which is limited
-           to 32 bits, the left side may also not contain higher values !! }
-         use_small:=(psetdef(p^.right^.resulttype)^.settype=smallset) and
-                    ((p^.left^.resulttype^.deftype=orddef) and (porddef(p^.left^.resulttype)^.high<=32) or
-                     (p^.left^.resulttype^.deftype=enumdef) and (penumdef(p^.left^.resulttype)^.max<=32));
-
-         { Can we generate jumps? Possible for all types of sets }
-         genjumps:=(p^.right^.treetype=setconstn) and
-                   analizeset(p^.right^.value_set,use_small);
-         { calculate both operators }
-         { the complex one first }
-         firstcomplex(p);
-         secondpass(p^.left);
-         { Only process the right if we are not generating jumps }
-         if not genjumps then
-          begin
-            pushed:=maybe_push(p^.right^.registers32,p^.left,false);
-            secondpass(p^.right);
-            if pushed then
-             restore(p^.left,false);
-          end;
-         if codegenerror then
-          exit;
-
-         { ofcourse not commutative }
-         if p^.swaped then
-          swaptree(p);
-
-         if genjumps then
-          begin
-            { It gives us advantage to check for the set elements
-              separately instead of using the SET_IN_BYTE procedure.
-              To do: Build in support for LOC_JUMP }
-
-            { If register is used, use only lower 8 bits }
-            if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-             begin
-               pleftreg:=p^.left^.location.register;
-               if pleftreg in [R_AX..R_DX] then
-                begin
-                  emit_const_reg(A_AND,S_W,255,pleftreg);
-                  opsize:=S_W;
-                end
-               else
-                if pleftreg in [R_EAX..R_EDI] then
-                 begin
-                   emit_const_reg(A_AND,S_L,255,pleftreg);
-                   opsize:=S_L;
-                 end
-               else
-                opsize:=S_B;
-             end;
-
-            { Get a label to jump to the end }
-            p^.location.loc:=LOC_FLAGS;
-
-            { It's better to use the zero flag when there are
-              no ranges }
-            if ranges then
-              p^.location.resflags:=F_C
-            else
-              p^.location.resflags:=F_E;
-
-            getlabel(l);
-
-            for i:=1 to numparts do
-             if setparts[i].range then
-              begin
-                { Check if left is in a range }
-                { Get a label to jump over the check }
-                getlabel(l2);
-                if setparts[i].start=setparts[i].stop-1 then
-                 begin
-                   case p^.left^.location.loc of
-                  LOC_REGISTER,
-                 LOC_CREGISTER : emit_const_reg(A_CMP,opsize,
-                                   setparts[i].start,pleftreg);
-                   else
-                     emit_const_ref(A_CMP,S_B,
-                       setparts[i].start,newreference(p^.left^.location.reference));
-                   end;
-                   { Result should be in carry flag when ranges are used }
-                   if ranges then
-                     emit_none(A_STC,S_NO);
-                   { If found, jump to end }
-                   emitjmp(C_E,l);
-                   case p^.left^.location.loc of
-                  LOC_REGISTER,
-                 LOC_CREGISTER : emit_const_reg(A_CMP,opsize,
-                                   setparts[i].stop,pleftreg);
-                   else
-                     emit_const_ref(A_CMP,S_B,
-                       setparts[i].stop,newreference(p^.left^.location.reference));
-                   end;
-                   { Result should be in carry flag when ranges are used }
-                   if ranges then
-                     emit_none(A_STC,S_NO);
-                   { If found, jump to end }
-                   emitjmp(C_E,l);
-                 end
-                else
-                 begin
-                   if setparts[i].start<>0 then
-                    begin
-                      { We only check for the lower bound if it is > 0, because
-                        set elements lower than 0 dont exist }
-                      case p^.left^.location.loc of
-                     LOC_REGISTER,
-                    LOC_CREGISTER :
-                    emit_const_reg(A_CMP,opsize,
-                                      setparts[i].start,pleftreg);
-                      else
-                        emit_const_ref(A_CMP,S_B,
-                          setparts[i].start,newreference(p^.left^.location.reference));
-                      end;
-                      { If lower, jump to next check }
-                      emitjmp(C_B,l2);
-                    end;
-                   { We only check for the high bound if it is < 255, because
-                     set elements higher than 255 do nt exist, the its always true,
-                     so only a JMP is generated }
-                   if setparts[i].stop<>255 then
-                    begin
-                      case p^.left^.location.loc of
-                     LOC_REGISTER,
-                    LOC_CREGISTER : emit_const_reg(A_CMP,opsize,
-                                      setparts[i].stop+1,pleftreg);
-                      else
-                        emit_const_ref(A_CMP,S_B,
-                          setparts[i].stop+1,newreference(p^.left^.location.reference));
-                      end;
-                      { If higher, element is in set }
-                      emitjmp(C_B,l);
-                    end
-                   else
-                    begin
-                      emit_none(A_STC,S_NO);
-                      emitjmp(C_None,l);
-                    end;
-                 end;
-                { Emit the jump over label }
-                emitlab(l2);
-              end
-             else
-              begin
-                { Emit code to check if left is an element }
-                case p^.left^.location.loc of
-               LOC_REGISTER,
-              LOC_CREGISTER : emit_const_reg(A_CMP,opsize,
-                                setparts[i].stop,pleftreg);
-                else
-                  emit_const_ref(A_CMP,S_B,
-                    setparts[i].stop,newreference(p^.left^.location.reference));
-                end;
-                { Result should be in carry flag when ranges are used }
-                if ranges then
-                 emit_none(A_STC,S_NO);
-                { If found, jump to end }
-                emitjmp(C_E,l);
-              end;
-             if ranges then
-              emit_none(A_CLC,S_NO);
-             { To compensate for not doing a second pass }
-             p^.right^.location.reference.symbol:=nil;
-             { Now place the end label }
-             emitlab(l);
-             case p^.left^.location.loc of
-            LOC_REGISTER,
-           LOC_CREGISTER : ungetregister32(pleftreg);
-             else
-               del_reference(p^.left^.location.reference);
-             end;
-          end
-         else
-          begin
-          { We will now generated code to check the set itself, no jmps,
-            handle smallsets separate, because it allows faster checks }
-            if use_small then
-             begin
-               if p^.left^.treetype=ordconstn then
-                begin
-                  p^.location.resflags:=F_NE;
-                  case p^.right^.location.loc of
-                     LOC_REGISTER,
-                     LOC_CREGISTER:
-                      begin
-                         emit_const_reg(A_TEST,S_L,
-                           1 shl (p^.left^.value and 31),p^.right^.location.register);
-                         ungetregister32(p^.right^.location.register);
-                       end
-                  else
-                   begin
-                     emit_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31),
-                       newreference(p^.right^.location.reference));
-                     del_reference(p^.right^.location.reference);
-                   end;
-                  end;
-                end
-               else
-                begin
-                  case p^.left^.location.loc of
-                     LOC_REGISTER,
-                     LOC_CREGISTER:
-                       begin
-                          hr:=p^.left^.location.register;
-                          emit_to_reg32(hr);
-                       end;
-                  else
-                    begin
-                      { the set element isn't never samller than a byte  }
-                      { and because it's a small set we need only 5 bits }
-                      { but 8 bits are easier to load               }
-{$ifndef noAllocEdi}
-                      getexplicitregister32(R_EDI);
-{$endif noAllocEdi}
-                      emit_ref_reg(A_MOVZX,S_BL,
-                        newreference(p^.left^.location.reference),R_EDI);
-                      hr:=R_EDI;
-                      del_reference(p^.left^.location.reference);
-                    end;
-                  end;
-
-                  case p^.right^.location.loc of
-                 LOC_REGISTER,
-                LOC_CREGISTER :
-                          begin
-                            emit_reg_reg(A_BT,S_L,hr,
-                              p^.right^.location.register);
-                            ungetregister32(p^.right^.location.register);
-                          end
-                  else
-                    begin
-                      del_reference(p^.right^.location.reference);
-                      if p^.right^.location.reference.is_immediate then
-                       begin
-                       { We have to load the value into a register because
-                         btl does not accept values only refs or regs (PFV) }
-                         hr2:=getregister32;
-                         emit_const_reg(A_MOV,S_L,
-                           p^.right^.location.reference.offset,hr2);
-                         emit_reg_reg(A_BT,S_L,hr,hr2);
-                         ungetregister32(hr2);
-                       end
-                      else
-                        emit_reg_ref(A_BT,S_L,hr,
-                          newreference(p^.right^.location.reference));
-                    end;
-                  end;
-{$ifndef noAllocEdi}
-                  { simply to indicate EDI is deallocated here too (JM) }
-                  ungetregister32(hr);
-{$else noAllocEdi}
-                  ungetregister32(hr);
-{$endif noAllocEdi}
-                  p^.location.loc:=LOC_FLAGS;
-                  p^.location.resflags:=F_C;
-                end;
-             end
-            else
-             begin
-               if p^.right^.location.reference.is_immediate then
-                begin
-                  p^.location.resflags:=F_C;
-                  getlabel(l);
-                  getlabel(l2);
-
-                  { Is this treated in firstpass ?? }
-                  if p^.left^.treetype=ordconstn then
-                    begin
-                      hr:=getregister32;
-                      p^.left^.location.loc:=LOC_REGISTER;
-                      p^.left^.location.register:=hr;
-                      emit_const_reg(A_MOV,S_L,
-                            p^.left^.value,hr);
-                    end;
-                  case p^.left^.location.loc of
-                     LOC_REGISTER,
-                     LOC_CREGISTER:
-                       begin
-                          hr:=p^.left^.location.register;
-                          emit_to_reg32(hr);
-                          emit_const_reg(A_CMP,S_L,31,hr);
-                          emitjmp(C_NA,l);
-                        { reset carry flag }
-                          emit_none(A_CLC,S_NO);
-                          emitjmp(C_NONE,l2);
-                          emitlab(l);
-                        { We have to load the value into a register because
-                          btl does not accept values only refs or regs (PFV) }
-                          hr2:=getregister32;
-                          emit_const_reg(A_MOV,S_L,p^.right^.location.reference.offset,hr2);
-                          emit_reg_reg(A_BT,S_L,hr,hr2);
-                          ungetregister32(hr2);
-                       end;
-                  else
-                    begin
-{$ifdef CORRECT_SET_IN_FPC}
-                          if m_tp in aktmodeswitches then
-                            begin
-                            {***WARNING only correct if
-                              reference is 32 bits (PM) *****}
-                               emit_const_ref(A_CMP,S_L,
-                                 31,newreference(p^.left^.location.reference));
-                            end
-                          else
-{$endif CORRECT_SET_IN_FPC}
-                            begin
-                               emit_const_ref(A_CMP,S_B,
-                                 31,newreference(p^.left^.location.reference));
-                            end;
-                       emitjmp(C_NA,l);
-                     { reset carry flag }
-                       emit_none(A_CLC,S_NO);
-                       emitjmp(C_NONE,l2);
-                       emitlab(l);
-                       del_reference(p^.left^.location.reference);
-                       hr:=getregister32;
-                       emit_ref_reg(A_MOV,S_L,
-                         newreference(p^.left^.location.reference),hr);
-                     { We have to load the value into a register because
-                       btl does not accept values only refs or regs (PFV) }
-                       hr2:=getregister32;
-                       emit_const_reg(A_MOV,S_L,
-                         p^.right^.location.reference.offset,hr2);
-                       emit_reg_reg(A_BT,S_L,hr,hr2);
-                       ungetregister32(hr2);
-                    end;
-                  end;
-                  emitlab(l2);
-                end { of p^.right^.location.reference.is_immediate }
-               { do search in a normal set which could have >32 elementsm
-                 but also used if the left side contains higher values > 32 }
-               else if p^.left^.treetype=ordconstn then
-                begin
-                  p^.location.resflags:=F_NE;
-                  inc(p^.right^.location.reference.offset,p^.left^.value shr 3);
-                  emit_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7),
-                    newreference(p^.right^.location.reference));
-                  del_reference(p^.right^.location.reference);
-                end
-               else
-                begin
-                  pushsetelement(p^.left);
-                  emitpushreferenceaddr(p^.right^.location.reference);
-                  del_reference(p^.right^.location.reference);
-                  { registers need not be save. that happens in SET_IN_BYTE }
-                  { (EDI is changed) }
-                  emitcall('FPC_SET_IN_BYTE');
-                  { ungetiftemp(p^.right^.location.reference); }
-                  p^.location.loc:=LOC_FLAGS;
-                  p^.location.resflags:=F_C;
-                end;
-             end;
-          end;
-          if (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-            ungetiftemp(p^.right^.location.reference);
-       end;
-
-
-{*****************************************************************************
-                              SecondCase
-*****************************************************************************}
-
-    procedure secondcase(var p : ptree);
-      var
-         with_sign : boolean;
-         opsize : topsize;
-         jmp_gt,jmp_le,jmp_lee : tasmcond;
-         hp : ptree;
-         { register with case expression }
-         hregister,hregister2 : tregister;
-         endlabel,elselabel : pasmlabel;
-
-         { true, if we can omit the range check of the jump table }
-         jumptable_no_range : boolean;
-         { where to put the jump table }
-         jumpsegment : paasmoutput;
-         min_label : TConstExprInt;
-
-      procedure gentreejmp(p : pcaserecord);
-
-        var
-           lesslabel,greaterlabel : pasmlabel;
-
-       begin
-         emitlab(p^._at);
-         { calculate labels for left and right }
-         if (p^.less=nil) then
-           lesslabel:=elselabel
-         else
-           lesslabel:=p^.less^._at;
-         if (p^.greater=nil) then
-           greaterlabel:=elselabel
-         else
-           greaterlabel:=p^.greater^._at;
-           { calculate labels for left and right }
-         { no range label: }
-         if p^._low=p^._high then
-           begin
-              emit_const_reg(A_CMP,opsize,p^._low,hregister);
-              if greaterlabel=lesslabel then
-                emitjmp(C_NE,lesslabel)
-              else
-                begin
-                   emitjmp(jmp_le,lesslabel);
-                   emitjmp(jmp_gt,greaterlabel);
-                end;
-              emitjmp(C_None,p^.statement);
-           end
-         else
-           begin
-              emit_const_reg(A_CMP,opsize,p^._low,hregister);
-              emitjmp(jmp_le,lesslabel);
-              emit_const_reg(A_CMP,opsize,p^._high,hregister);
-              emitjmp(jmp_gt,greaterlabel);
-              emitjmp(C_None,p^.statement);
-           end;
-          if assigned(p^.less) then
-           gentreejmp(p^.less);
-          if assigned(p^.greater) then
-           gentreejmp(p^.greater);
-      end;
-
-      procedure genlinearcmplist(hp : pcaserecord);
-
-        var
-           first : boolean;
-           last : TConstExprInt;
-
-        procedure genitem(t : pcaserecord);
-
-          var
-             l1 : pasmlabel;
-
-          begin
-             if assigned(t^.less) then
-               genitem(t^.less);
-             if t^._low=t^._high then
-               begin
-                  if opsize=S_Q then
-                    begin
-                       getlabel(l1);
-                       emit_const_reg(A_CMP,S_L,hi(int64(t^._low)),hregister2);
-                       emitjmp(C_NZ,l1);
-                       emit_const_reg(A_CMP,S_L,lo(int64(t^._low)),hregister);
-                       emitjmp(C_Z,t^.statement);
-                       emitlab(l1);
-                    end
-                  else
-                    begin
-                       emit_const_reg(A_CMP,opsize,t^._low,hregister);
-                       emitjmp(C_Z,t^.statement);
-                       last:=t^._low;
-                    end;
-               end
-             else
-               begin
-                  { if there is no unused label between the last and the }
-                  { present label then the lower limit can be checked    }
-                  { immediately. else check the range in between:        }
-                  if first or (t^._low-last>1) then
-                    begin
-                       if opsize=S_Q then
-                         begin
-                            getlabel(l1);
-                            emit_const_reg(A_CMP,S_L,hi(int64(t^._low)),hregister2);
-                            emitjmp(jmp_le,elselabel);
-                            emitjmp(jmp_gt,l1);
-                            emit_const_reg(A_CMP,S_L,lo(int64(t^._low)),hregister);
-                            { the comparisation of the low dword must be always unsigned! }
-                            emitjmp(C_B,elselabel);
-                            emitlab(l1);
-                         end
-                       else
-                         begin
-                            emit_const_reg(A_CMP,opsize,t^._low,hregister);
-                            emitjmp(jmp_le,elselabel);
-                         end;
-                    end;
-
-                  if opsize=S_Q then
-                    begin
-                       getlabel(l1);
-                       emit_const_reg(A_CMP,S_L,hi(int64(t^._high)),hregister2);
-                       emitjmp(jmp_le,t^.statement);
-                       emitjmp(jmp_gt,l1);
-                       emit_const_reg(A_CMP,S_L,lo(int64(t^._high)),hregister);
-                       { the comparisation of the low dword must be always unsigned! }
-                       emitjmp(C_BE,t^.statement);
-                       emitlab(l1);
-                    end
-                  else
-                    begin
-                       emit_const_reg(A_CMP,opsize,t^._high,hregister);
-                       emitjmp(jmp_lee,t^.statement);
-                    end;
-
-                  last:=t^._high;
-               end;
-             first:=false;
-             if assigned(t^.greater) then
-               genitem(t^.greater);
-          end;
-
-        begin
-           last:=0;
-           first:=true;
-           genitem(hp);
-           emitjmp(C_None,elselabel);
-        end;
-
-      procedure genlinearlist(hp : pcaserecord);
-
-        var
-           first : boolean;
-           last : TConstExprInt;
-           {helplabel : longint;}
-
-        procedure genitem(t : pcaserecord);
-
-            procedure gensub(value:longint);
-            begin
-              if value=1 then
-                emit_reg(A_DEC,opsize,hregister)
-              else
-                emit_const_reg(A_SUB,opsize,value,hregister);
-            end;
-
-          begin
-             if assigned(t^.less) then
-               genitem(t^.less);
-             { need we to test the first value }
-             if first and (t^._low>get_min_value(p^.left^.resulttype)) then
-               begin
-                  emit_const_reg(A_CMP,opsize,t^._low,hregister);
-                  emitjmp(jmp_le,elselabel);
-               end;
-             if t^._low=t^._high then
-               begin
-                  if t^._low-last=0 then
-                    emit_reg_reg(A_OR,opsize,hregister,hregister)
-                  else
-                    gensub(t^._low-last);
-                  last:=t^._low;
-                  emitjmp(C_Z,t^.statement);
-               end
-             else
-               begin
-                  { it begins with the smallest label, if the value }
-                  { is even smaller then jump immediately to the    }
-                  { ELSE-label                                }
-                  if first then
-                    begin
-                       { have we to ajust the first value ? }
-                       if t^._low>get_min_value(p^.left^.resulttype) then
-                         gensub(t^._low);
-                    end
-                  else
-                    begin
-                      { if there is no unused label between the last and the }
-                      { present label then the lower limit can be checked    }
-                      { immediately. else check the range in between:       }
-                      emit_const_reg(A_SUB,opsize,t^._low-last,hregister);
-                      emitjmp(jmp_le,elselabel);
-                    end;
-                  emit_const_reg(A_SUB,opsize,t^._high-t^._low,hregister);
-                  emitjmp(jmp_lee,t^.statement);
-                  last:=t^._high;
-               end;
-             first:=false;
-             if assigned(t^.greater) then
-               genitem(t^.greater);
-          end;
-
-        begin
-           { do we need to generate cmps? }
-           if (with_sign and (min_label<0)) then
-             genlinearcmplist(hp)
-           else
-             begin
-                last:=0;
-                first:=true;
-                genitem(hp);
-                emitjmp(C_None,elselabel);
-             end;
-        end;
-
-      procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
-
-        var
-           table : pasmlabel;
-           last : TConstExprInt;
-           hr : preference;
-
-        procedure genitem(t : pcaserecord);
-
-          var
-             i : longint;
-
-          begin
-             if assigned(t^.less) then
-               genitem(t^.less);
-             { fill possible hole }
-             for i:=last+1 to t^._low-1 do
-               jumpsegment^.concat(new(pai_const_symbol,init(elselabel)));
-             for i:=t^._low to t^._high do
-               jumpsegment^.concat(new(pai_const_symbol,init(t^.statement)));
-              last:=t^._high;
-             if assigned(t^.greater) then
-               genitem(t^.greater);
-            end;
-
-          begin
-           if not(jumptable_no_range) then
-             begin
-                emit_const_reg(A_CMP,opsize,min_,hregister);
-                { case expr less than min_ => goto elselabel }
-                emitjmp(jmp_le,elselabel);
-                emit_const_reg(A_CMP,opsize,max_,hregister);
-                emitjmp(jmp_gt,elselabel);
-             end;
-           getlabel(table);
-           { extend with sign }
-           if opsize=S_W then
-             begin
-                if with_sign then
-                  emit_reg_reg(A_MOVSX,S_WL,hregister,
-                    reg16toreg32(hregister))
-                else
-                  emit_reg_reg(A_MOVZX,S_WL,hregister,
-                    reg16toreg32(hregister));
-                hregister:=reg16toreg32(hregister);
-             end
-           else if opsize=S_B then
-             begin
-                if with_sign then
-                  emit_reg_reg(A_MOVSX,S_BL,hregister,
-                    reg8toreg32(hregister))
-                else
-                  emit_reg_reg(A_MOVZX,S_BL,hregister,
-                    reg8toreg32(hregister));
-                hregister:=reg8toreg32(hregister);
-             end;
-           new(hr);
-           reset_reference(hr^);
-           hr^.symbol:=table;
-           hr^.offset:=(-min_)*4;
-           hr^.index:=hregister;
-           hr^.scalefactor:=4;
-           emit_ref(A_JMP,S_NO,hr);
-           { !!!!! generate tables
-             if not(cs_littlesize in aktlocalswitches) then
-             jumpsegment^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4)));
-           }
-           jumpsegment^.concat(new(pai_label,init(table)));
-             last:=min_;
-           genitem(hp);
-             { !!!!!!!
-           if not(cs_littlesize in aktlocalswitches) then
-             emit_const(A_ALIGN,S_NO,4);
-           }
-        end;
-
-      var
-         lv,hv,max_label,labels : longint;
-         max_linear_list : longint;
-         otl, ofl: pasmlabel;
-{$ifdef Delphi}
-         dist : cardinal;
-{$else Delphi}
-         dist : dword;
-{$endif Delphi}
-         hr : preference;
-
-      begin
-         getlabel(endlabel);
-         getlabel(elselabel);
-         if (cs_create_smart in aktmoduleswitches) then
-           jumpsegment:=procinfo^.aktlocaldata
-         else
-           jumpsegment:=datasegment;
-         with_sign:=is_signed(p^.left^.resulttype);
-         if with_sign then
-           begin
-              jmp_gt:=C_G;
-              jmp_le:=C_L;
-              jmp_lee:=C_LE;
-           end
-         else
-            begin
-              jmp_gt:=C_A;
-              jmp_le:=C_B;
-              jmp_lee:=C_BE;
-           end;
-         cleartempgen;
-         { save current truelabel and falselabel (they are restored in }
-         { locjump2reg) (JM)                                           }
-         if p^.left^.location.loc=LOC_JUMP then
-           begin
-            otl:=truelabel;
-            getlabel(truelabel);
-            ofl:=falselabel;
-            getlabel(falselabel);
-           end;
-         secondpass(p^.left);
-         { determines the size of the operand }
-         opsize:=bytes2Sxx[p^.left^.resulttype^.size];
-         { copy the case expression to a register }
-         case p^.left^.location.loc of
-            LOC_REGISTER:
-              begin
-                 if opsize=S_Q then
-                   begin
-                      hregister:=p^.left^.location.registerlow;
-                      hregister2:=p^.left^.location.registerhigh;
-                   end
-                 else
-                   hregister:=p^.left^.location.register;
-              end;
-            LOC_FLAGS :
-              begin
-                locflags2reg(p^.left^.location,opsize);
-                hregister := p^.left^.location.register;
-              end;
-            LOC_JUMP:
-              begin
-                locjump2reg(p^.left^.location,opsize,otl,ofl);
-                hregister := p^.left^.location.register;
-              end;
-            LOC_CREGISTER:
-              begin
-                 hregister:=getregister32;
-                 case opsize of
-                    S_B:
-                      hregister:=reg32toreg8(hregister);
-                    S_W:
-                      hregister:=reg32toreg16(hregister);
-                    S_Q:
-                      hregister2:=R_EDI;
-                 end;
-                 if opsize=S_Q then
-                   begin
-                      emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,hregister);
-                      hr:=newreference(p^.left^.location.reference);
-                      inc(hr^.offset,4);
-                      emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,hregister2);
-                   end
-                 else
-                   emit_reg_reg(A_MOV,opsize,
-                     p^.left^.location.register,hregister);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 del_reference(p^.left^.location.reference);
-                 hregister:=getregister32;
-                 case opsize of
-                    S_B:
-                      hregister:=reg32toreg8(hregister);
-                    S_W:
-                      hregister:=reg32toreg16(hregister);
-                    S_Q:
-                      hregister2:=R_EDI;
-                 end;
-                 if opsize=S_Q then
-                   begin
-                      emit_ref_reg(A_MOV,S_L,newreference(
-                        p^.left^.location.reference),hregister);
-                      hr:=newreference(p^.left^.location.reference);
-                      inc(hr^.offset,4);
-                      emit_ref_reg(A_MOV,S_L,hr,hregister2);
-                   end
-                 else
-                   emit_ref_reg(A_MOV,opsize,newreference(
-                     p^.left^.location.reference),hregister);
-              end;
-            else internalerror(2002);
-         end;
-         { we need the min_label always to choose between }
-         { cmps and subs/decs                             }
-         min_label:=case_get_min(p^.nodes);
-         { now generate the jumps }
-         if opsize=S_Q then
-           genlinearcmplist(p^.nodes)
-         else
-           begin
-              if cs_optimize in aktglobalswitches then
-                begin
-                   { procedures are empirically passed on }
-                   { consumption can also be calculated   }
-                   { but does it pay on the different     }
-                   { processors?                       }
-                   { moreover can the size only be appro- }
-                   { ximated as it is not known if rel8,  }
-                   { rel16 or rel32 jumps are used   }
-                   max_label:=case_get_max(p^.nodes);
-                   labels:=case_count_labels(p^.nodes);
-                   { can we omit the range check of the jump table ? }
-                   getrange(p^.left^.resulttype,lv,hv);
-                   jumptable_no_range:=(lv=min_label) and (hv=max_label);
-                   { hack a little bit, because the range can be greater }
-                   { than the positive range of a longint            }
-
-                   if (min_label<0) and (max_label>0) then
-                     begin
-{$ifdef Delphi}
-                        if min_label=longint($80000000) then
-                          dist:=Cardinal(max_label)+Cardinal($80000000)
-                        else
-                          dist:=Cardinal(max_label)+Cardinal(-min_label)
-{$else Delphi}
-                        if min_label=$80000000 then
-                          dist:=dword(max_label)+dword($80000000)
-                        else
-                          dist:=dword(max_label)+dword(-min_label)
-{$endif Delphi}
-                     end
-                   else
-                     dist:=max_label-min_label;
-
-                   { optimize for size ? }
-                   if cs_littlesize in aktglobalswitches  then
-                     begin
-                        if (labels<=2) or
-                           ((max_label-min_label)<0) or
-                           ((max_label-min_label)>3*labels) then
-                       { a linear list is always smaller than a jump tree }
-                          genlinearlist(p^.nodes)
-                        else
-                       { if the labels less or more a continuum then }
-                          genjumptable(p^.nodes,min_label,max_label);
-                     end
-                   else
-                     begin
-                        if jumptable_no_range then
-                          max_linear_list:=4
-                        else
-                          max_linear_list:=2;
-                        { a jump table crashes the pipeline! }
-                        if aktoptprocessor=Class386 then
-                          inc(max_linear_list,3);
-                            if aktoptprocessor=ClassP5 then
-                          inc(max_linear_list,6);
-                        if aktoptprocessor>=ClassP6 then
-                          inc(max_linear_list,9);
-
-                        if (labels<=max_linear_list) then
-                          genlinearlist(p^.nodes)
-                        else
-                          begin
-                             if (dist>4*labels) then
-                               begin
-                                  if labels>16 then
-                                    gentreejmp(p^.nodes)
-                                  else
-                                    genlinearlist(p^.nodes);
-                               end
-                             else
-                               genjumptable(p^.nodes,min_label,max_label);
-                          end;
-                     end;
-                end
-              else
-                { it's always not bad }
-                genlinearlist(p^.nodes);
-           end;
-
-         ungetregister(hregister);
-
-         { now generate the instructions }
-         hp:=p^.right;
-         while assigned(hp) do
-           begin
-              cleartempgen;
-              secondpass(hp^.right);
-              { don't come back to case line }
-              aktfilepos:=exprasmlist^.getlasttaifilepos^;
-              emitjmp(C_None,endlabel);
-              hp:=hp^.left;
-           end;
-         emitlab(elselabel);
-         { ...and the else block }
-         if assigned(p^.elseblock) then
-           begin
-              cleartempgen;
-              secondpass(p^.elseblock);
-           end;
-         emitlab(endlabel);
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.7  2000/09/24 21:19:49  peter
-    * delphi compile fixes
-
-  Revision 1.6  2000/08/12 06:47:56  florian
-    + case statement for int64/qword implemented
-
-  Revision 1.5  2000/08/05 09:57:27  jonas
-    * added missing register deallocation (could cause IE10 i some cases)
-      (merged from fixes branch)
-
-  Revision 1.4  2000/07/30 17:04:43  peter
-    * merged fixes
-
-  Revision 1.3  2000/07/27 09:25:05  jonas
-    * moved locflags2reg() procedure from cg386add to cgai386
-    + added locjump2reg() procedure to cgai386
-    * fixed internalerror(2002) when the result of a case expression has
-      LOC_JUMP
-    (all merged from fixes branch)
-
-  Revision 1.2  2000/07/13 11:32:35  michael
-  + removed logs
-
-}

compiler/old/cg68kadd.pas

@@ -1,1293 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for add node
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-{$ifdef FPC}
-  {$goto on}
-{$endif FPC}
-unit cg68kadd;
-interface
-
-    uses
-      tree;
-
-    procedure secondadd(var p : ptree);
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      temp_gen,hcodegen,pass_2,cpubase,
-      cga68k,tgen68k;
-
-{*****************************************************************************
-                                Helpers
-*****************************************************************************}
-
- procedure processcc(p: ptree);
- const
-       { process condition codes bit definitions }
-       CARRY_FLAG    = $01;
-       OVFL_FLAG     = $02;
-       ZERO_FLAG     = $04;
-       NEG_FLAG      = $08;
- var
-   label1,label2: pasmlabel;
- (*************************************************************************)
- (*  Description: This routine handles the conversion of Floating point   *)
- (*  condition codes to normal cpu condition codes.                       *)
- (*************************************************************************)
- begin
-      getlabel(label1);
-      getlabel(label2);
-      case p^.treetype of
-        equaln,unequaln: begin
-                           { not equal clear zero flag }
-                           emitl(A_FBEQ,label1);
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND, S_B, NOT ZERO_FLAG, R_CCR)));
-                           emitl(A_BRA,label2);
-                           emitl(A_LABEL,label1);
-                           { equal - set zero flag }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR,S_B, ZERO_FLAG, R_CCR)));
-                           emitl(A_LABEL,label2);
-                        end;
-         ltn:           begin
-                           emitl(A_FBLT,label1);
-                           { not less than       }
-                           { clear N and V flags }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND, S_B, NOT (NEG_FLAG OR OVFL_FLAG), R_CCR)));
-                           emitl(A_BRA,label2);
-                           emitl(A_LABEL,label1);
-                           { less than }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR,S_B, NEG_FLAG, R_CCR)));
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND,S_B, NOT OVFL_FLAG, R_CCR)));
-                           emitl(A_LABEL,label2);
-                        end;
-         gtn:           begin
-                           emitl(A_FBGT,label1);
-                           { not greater than }
-                           { set Z flag       }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR, S_B, ZERO_FLAG, R_CCR)));
-                           emitl(A_BRA,label2);
-                           emitl(A_LABEL,label1);
-                           { greater than      }
-                           { set N and V flags }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR,S_B, NEG_FLAG OR OVFL_FLAG , R_CCR)));
-                           emitl(A_LABEL,label2);
-                        end;
-         gten:           begin
-                           emitl(A_FBGE,label1);
-                           { not greater or equal }
-                           { set N and clear V    }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND, S_B, NOT OVFL_FLAG, R_CCR)));
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR,S_B, NEG_FLAG, R_CCR)));
-                           emitl(A_BRA,label2);
-                           emitl(A_LABEL,label1);
-                           { greater or equal    }
-                           { clear V and N flags }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND, S_B, NOT (OVFL_FLAG OR NEG_FLAG), R_CCR)));
-                           emitl(A_LABEL,label2);
-                        end;
-         lten:           begin
-                           emitl(A_FBLE,label1);
-                           { not less or equal }
-                           { clear Z, N and V  }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND, S_B, NOT (ZERO_FLAG OR NEG_FLAG OR OVFL_FLAG), R_CCR)));
-                           emitl(A_BRA,label2);
-                           emitl(A_LABEL,label1);
-                           { less or equal     }
-                           { set Z and N       }
-                           { and clear V       }
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_OR,S_B, ZERO_FLAG OR NEG_FLAG, R_CCR)));
-                           exprasmlist^.concat(new(paicpu, op_const_reg(
-                             A_AND,S_B, NOT OVFL_FLAG, R_CCR)));
-                           emitl(A_LABEL,label2);
-                        end;
-           else
-             begin
-               InternalError(34);
-             end;
-      end; { end case }
- end;
-
-
-    procedure SetResultLocation(cmpop,unsigned:boolean;var p :ptree);
-      var
-         flags : tresflags;
-      begin
-         { remove temporary location if not a set or string }
-         { that's a hack (FK)                               }
-         if (p^.left^.resulttype^.deftype<>stringdef) and
-            ((p^.left^.resulttype^.deftype<>setdef) or (psetdef(p^.left^.resulttype)^.settype=smallset)) and
-            (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-           ungetiftemp(p^.left^.location.reference);
-         if (p^.right^.resulttype^.deftype<>stringdef) and
-            ((p^.right^.resulttype^.deftype<>setdef) or (psetdef(p^.right^.resulttype)^.settype=smallset)) and
-            (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-           ungetiftemp(p^.right^.location.reference);
-         { in case of comparison operation the put result in the flags }
-         if cmpop then
-           begin
-              if not(unsigned) then
-                begin
-                   if p^.swaped then
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_G;
-                        lten : flags:=F_GE;
-                        gtn : flags:=F_L;
-                        gten : flags:=F_LE;
-                     end
-                   else
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_L;
-                        lten : flags:=F_LE;
-                        gtn : flags:=F_G;
-                        gten : flags:=F_GE;
-                     end;
-                end
-              else
-                begin
-                   if p^.swaped then
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_A;
-                        lten : flags:=F_AE;
-                        gtn : flags:=F_B;
-                        gten : flags:=F_BE;
-                     end
-                   else
-                     case p^.treetype of
-                        equaln : flags:=F_E;
-                        unequaln : flags:=F_NE;
-                        ltn : flags:=F_B;
-                        lten : flags:=F_BE;
-                        gtn : flags:=F_A;
-                        gten : flags:=F_AE;
-                     end;
-                end;
-              clear_location(p^.location);
-              p^.location.loc:=LOC_FLAGS;
-              p^.location.resflags:=flags;
-           end;
-      end;
-
-
-{*****************************************************************************
-                                Addstring
-*****************************************************************************}
-
-    procedure addstring(var p : ptree);
-      var
-        pushedregs : tpushed;
-        href       : treference;
-        pushed,
-        cmpop      : boolean;
-      begin
-        { string operations are not commutative }
-        if p^.swaped then
-          swaptree(p);
-        case pstringdef(p^.left^.resulttype)^.string_typ of
-           st_ansistring:
-             begin
-                case p^.treetype of
-                addn :
-                  begin
-                     { we do not need destination anymore }
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     { concatansistring(p); }
-                  end;
-                ltn,lten,gtn,gten,
-                equaln,unequaln :
-                  begin
-                     pushusedregisters(pushedregs,$ff);
-                     secondpass(p^.left);
-                     del_reference(p^.left^.location.reference);
-                     emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                     secondpass(p^.right);
-                     del_reference(p^.right^.location.reference);
-                     emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
-                     emitcall('FPC_ANSISTRCMP',true);
-                     maybe_loada5;
-                     popusedregisters(pushedregs);
-                  end;
-                end;
-             end;
-           st_shortstring:
-             begin
-                case p^.treetype of
-                   addn : begin
-                             cmpop:=false;
-                             secondpass(p^.left);
-                             if (p^.left^.treetype<>addn) then
-                               begin
-                                  { can only reference be }
-                                  { string in register would be funny    }
-                                  { therefore produce a temporary string }
-
-                                  { release the registers }
-                                  del_reference(p^.left^.location.reference);
-                                  gettempofsizereference(256,href);
-                                  copystring(href,p^.left^.location.reference,255);
-                                  ungetiftemp(p^.left^.location.reference);
-
-                                  { does not hurt: }
-                                  clear_location(p^.left^.location);
-                                  p^.left^.location.loc:=LOC_MEM;
-                                  p^.left^.location.reference:=href;
-                               end;
-
-                             secondpass(p^.right);
-
-                             { on the right we do not need the register anymore too }
-                             del_reference(p^.right^.location.reference);
-                             pushusedregisters(pushedregs,$ffff);
-                             { WE INVERSE THE PARAMETERS!!! }
-                             { Because parameters are inversed in the rtl }
-                             emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
-                             emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                             emitcall('FPC_STRCONCAT',true);
-                             maybe_loadA5;
-                             popusedregisters(pushedregs);
-                             set_location(p^.location,p^.left^.location);
-                             ungetiftemp(p^.right^.location.reference);
-                          end; { this case }
-                ltn,lten,gtn,gten,
-                  equaln,unequaln :
-                          begin
-                             secondpass(p^.left);
-                             { are too few registers free? }
-                             pushed:=maybe_push(p^.right^.registers32,p);
-                             secondpass(p^.right);
-                             if pushed then restore(p);
-                             cmpop:=true;
-                             del_reference(p^.right^.location.reference);
-                             del_reference(p^.left^.location.reference);
-                             { generates better code }
-                             { s='' and s<>''        }
-                             if (p^.treetype in [equaln,unequaln]) and
-                               (
-                                 ((p^.left^.treetype=stringconstn) and
-                                  (str_length(p^.left)=0)) or
-                                 ((p^.right^.treetype=stringconstn) and
-                                  (str_length(p^.right)=0))
-                               ) then
-                               begin
-                                  { only one node can be stringconstn }
-                                  { else pass 1 would have evaluted   }
-                                  { this node                         }
-                                  if p^.left^.treetype=stringconstn then
-                                    exprasmlist^.concat(new(paicpu,op_ref(
-                                      A_TST,S_B,newreference(p^.right^.location.reference))))
-                                  else
-                                    exprasmlist^.concat(new(paicpu,op_ref(
-                                      A_TST,S_B,newreference(p^.left^.location.reference))));
-                               end
-                             else
-                               begin
-                                 pushusedregisters(pushedregs,$ffff);
-
-                                 { parameters are directly passed via registers       }
-                                 { this has several advantages, no loss of the flags  }
-                                 { on exit ,and MUCH faster on m68k machines          }
-                                 {  speed difference (68000)                          }
-                                 {   normal routine: entry, exit code + push  = 124   }
-                                 {   (best case)                                      }
-                                 {   assembler routine: param setup (worst case) = 48 }
-
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(
-                                      A_LEA,S_L,newreference(p^.left^.location.reference),R_A0)));
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(
-                                      A_LEA,S_L,newreference(p^.right^.location.reference),R_A1)));
-                                 {
-                                 emitpushreferenceaddr(p^.left^.location.reference);
-                                 emitpushreferenceaddr(p^.right^.location.reference); }
-                                 emitcall('FPC_STRCMP',true);
-                                 maybe_loada5;
-                                 popusedregisters(pushedregs);
-                            end;
-                             ungetiftemp(p^.left^.location.reference);
-                             ungetiftemp(p^.right^.location.reference);
-                          end; { end this case }
-
-                   else CGMessage(type_e_mismatch);
-                end;
-             end; { end case }
-          end;
-        SetResultLocation(cmpop,true,p);
-      end;
-
-
-{*****************************************************************************
-                                Addset
-*****************************************************************************}
-
-    procedure addset(var p : ptree);
-      var
-        cmpop,
-        pushed : boolean;
-        href   : treference;
-        pushedregs : tpushed;
-      begin
-        cmpop:=false;
-
-        { not commutative }
-        if p^.swaped then
-         swaptree(p);
-
-        secondpass(p^.left);
-        { are too few registers free? }
-        pushed:=maybe_push(p^.right^.registers32,p);
-        secondpass(p^.right);
-        if codegenerror then
-          exit;
-        if pushed then
-          restore(p);
-
-        set_location(p^.location,p^.left^.location);
-
-        { handle operations }
-        case p^.treetype of
-          equaln,
-        unequaln : begin
-                     cmpop:=true;
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     pushusedregisters(pushedregs,$ff);
-                     emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
-                     emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                     emitcall('FPC_SET_COMP_SETS',true);
-                     maybe_loada5;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                   end;
-            addn : begin
-                   { add can be an other SET or Range or Element ! }
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     pushusedregisters(pushedregs,$ff);
-                     href.symbol:=nil;
-                     gettempofsizereference(32,href);
-                   { add a range or a single element? }
-                     if p^.right^.treetype=setelementn then
-                      begin
-                        concatcopy(p^.left^.location.reference,href,32,false);
-                        if assigned(p^.right^.right) then
-                         begin
-                           loadsetelement(p^.right^.right);
-                           loadsetelement(p^.right^.left);
-                           emitpushreferenceaddr(exprasmlist,href);
-                           emitcall('FPC_SET_SET_RANGE',true);
-                         end
-                        else
-                         begin
-                           loadsetelement(p^.right^.left);
-                           emitpushreferenceaddr(exprasmlist,href);
-                           emitcall('FPC_SET_SET_BYTE',true);
-                         end;
-                      end
-                     else
-                      begin
-                      { must be an other set }
-                        emitpushreferenceaddr(exprasmlist,href);
-                        emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
-                        emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                        emitcall('FPC_SET_ADD_SETS',true);
-                      end;
-                     maybe_loada5;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                     p^.location.loc:=LOC_MEM;
-                     stringdispose(p^.location.reference.symbol);
-                     p^.location.reference:=href;
-                   end;
-            subn,
-         symdifn,
-            muln : begin
-                     del_reference(p^.left^.location.reference);
-                     del_reference(p^.right^.location.reference);
-                     href.symbol:=nil;
-                     pushusedregisters(pushedregs,$ff);
-                     gettempofsizereference(32,href);
-                     emitpushreferenceaddr(exprasmlist,href);
-                     emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
-                     emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                     case p^.treetype of
-                      subn : emitcall('FPC_SET_SUB_SETS',true);
-                   symdifn : emitcall('FPC_SET_SYMDIF_SETS',true);
-                      muln : emitcall('FPC_SET_MUL_SETS',true);
-                     end;
-                     maybe_loada5;
-                     popusedregisters(pushedregs);
-                     ungetiftemp(p^.left^.location.reference);
-                     ungetiftemp(p^.right^.location.reference);
-                     p^.location.loc:=LOC_MEM;
-                     stringdispose(p^.location.reference.symbol);
-                     p^.location.reference:=href;
-                   end;
-        else
-          CGMessage(type_e_mismatch);
-        end;
-        SetResultLocation(cmpop,true,p);
-      end;
-
-
-{*****************************************************************************
-                                SecondAdd
-*****************************************************************************}
-
-    procedure secondadd(var p : ptree);
-    { is also being used for xor, and "mul", "sub, or and comparative }
-    { operators                                                       }
-
-      label do_normal;
-
-      var
-         hregister : tregister;
-         noswap,
-         pushed,mboverflow,cmpop : boolean;
-         op : tasmop;
-         flags : tresflags;
-         otl,ofl : pasmlabel;
-         power : longint;
-         opsize : topsize;
-         hl4: pasmlabel;
-         tmpref : treference;
-
-
-         { true, if unsigned types are compared }
-         unsigned : boolean;
-         { true, if a small set is handled with the longint code }
-         is_set : boolean;
-         { is_in_dest if the result is put directly into }
-         { the resulting refernce or varregister }
-         is_in_dest : boolean;
-         { true, if for sets subtractions the extra not should generated }
-         extra_not : boolean;
-
-      begin
-      { to make it more readable, string and set (not smallset!) have their
-        own procedures }
-         case p^.left^.resulttype^.deftype of
-         stringdef : begin
-                       addstring(p);
-                       exit;
-                     end;
-            setdef : begin
-                     { normalsets are handled separate }
-                       if not(psetdef(p^.left^.resulttype)^.settype=smallset) then
-                        begin
-                          addset(p);
-                          exit;
-                        end;
-                     end;
-         end;
-
-         { defaults }
-         unsigned:=false;
-         is_in_dest:=false;
-         extra_not:=false;
-         noswap:=false;
-         opsize:=S_L;
-
-         { are we a (small)set, must be set here because the side can be
-           swapped ! (PFV) }
-         is_set:=(p^.left^.resulttype^.deftype=setdef);
-
-         { calculate the operator which is more difficult }
-         firstcomplex(p);
-
-         { handling boolean expressions extra: }
-         if ((p^.left^.resulttype^.deftype=orddef) and
-            (porddef(p^.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) or
-            ((p^.right^.resulttype^.deftype=orddef) and
-            (porddef(p^.right^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) then
-           begin
-             if (porddef(p^.left^.resulttype)^.typ=bool8bit) or
-                (porddef(p^.right^.resulttype)^.typ=bool8bit) then
-               opsize:=S_B
-             else
-               if (porddef(p^.left^.resulttype)^.typ=bool16bit) or
-                  (porddef(p^.right^.resulttype)^.typ=bool16bit) then
-                 opsize:=S_W
-             else
-               opsize:=S_L;
-             case p^.treetype of
-              andn,
-               orn : begin
-                       clear_location(p^.location);
-                       p^.location.loc:=LOC_JUMP;
-                       cmpop:=false;
-                       case p^.treetype of
-                        andn : begin
-                                  otl:=truelabel;
-                                  getlabel(truelabel);
-                                  secondpass(p^.left);
-                                  maketojumpbool(p^.left);
-                                  emitl(A_LABEL,truelabel);
-                                  truelabel:=otl;
-                               end;
-                        orn : begin
-                                 ofl:=falselabel;
-                                 getlabel(falselabel);
-                                 secondpass(p^.left);
-                                 maketojumpbool(p^.left);
-                                 emitl(A_LABEL,falselabel);
-                                 falselabel:=ofl;
-                              end;
-                       else
-                         CGMessage(type_e_mismatch);
-                       end;
-                       secondpass(p^.right);
-                       maketojumpbool(p^.right);
-                     end;
-          unequaln,
-       equaln,xorn : begin
-                       if p^.left^.treetype=ordconstn then
-                        swaptree(p);
-                       secondpass(p^.left);
-                       set_location(p^.location,p^.left^.location);
-                       { are enough registers free ? }
-                       pushed:=maybe_push(p^.right^.registers32,p);
-                       secondpass(p^.right);
-                       if pushed then restore(p);
-                       goto do_normal;
-                    end
-             else
-               CGMessage(type_e_mismatch);
-             end
-           end
-         else
-           begin
-              { in case of constant put it to the left }
-              if (p^.left^.treetype=ordconstn) then
-               swaptree(p);
-              secondpass(p^.left);
-              { this will be complicated as
-               a lot of code below assumes that
-               p^.location and p^.left^.location are the same }
-
-{$ifdef test_dest_loc}
-              if dest_loc_known and (dest_loc_tree=p) and
-                 ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then
-                begin
-                   set_location(p^.location,dest_loc);
-                   in_dest_loc:=true;
-                   is_in_dest:=true;
-                end
-              else
-{$endif test_dest_loc}
-                set_location(p^.location,p^.left^.location);
-
-              { are too few registers free? }
-              pushed:=maybe_push(p^.right^.registers32,p);
-              secondpass(p^.right);
-              if pushed then
-                restore(p);
-
-              if (p^.left^.resulttype^.deftype=pointerdef) or
-
-                 (p^.right^.resulttype^.deftype=pointerdef) or
-
-                 ((p^.right^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.right^.resulttype)^.is_class and
-                 (p^.left^.resulttype^.deftype=objectdef) and
-                  pobjectdef(p^.left^.resulttype)^.is_class
-                 ) or
-
-                 (p^.left^.resulttype^.deftype=classrefdef) or
-
-                 (p^.left^.resulttype^.deftype=procvardef) or
-
-                 (p^.left^.resulttype^.deftype=enumdef) or
-
-                 ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=s32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=s32bit)) or
-
-                ((p^.left^.resulttype^.deftype=orddef) and
-                 (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                 ((p^.right^.resulttype^.deftype=orddef) and
-                 (porddef(p^.right^.resulttype)^.typ=u32bit)) or
-
-                { as well as small sets }
-                 is_set then
-                begin
-          do_normal:
-                   mboverflow:=false;
-                   cmpop:=false;
-                   if (p^.left^.resulttype^.deftype=pointerdef) or
-                      (p^.right^.resulttype^.deftype=pointerdef) or
-                      ((p^.left^.resulttype^.deftype=orddef) and
-                       (porddef(p^.left^.resulttype)^.typ=u32bit)) or
-                      ((p^.right^.resulttype^.deftype=orddef) and
-                       (porddef(p^.right^.resulttype)^.typ=u32bit)) then
-                     unsigned:=true;
-                   case p^.treetype of
-                      addn : begin
-                               if is_set then
-                                begin
-                                { adding elements is not commutative }
-                                  if p^.swaped and (p^.left^.treetype=setelementn) then
-                                   swaptree(p);
-                                { are we adding set elements ? }
-                                  if p^.right^.treetype=setelementn then
-                                   begin
-                                   { no range support for smallsets! }
-                                     if assigned(p^.right^.right) then
-                                      internalerror(43244);
-                                   { Not supported for m68k}
-                                     Comment(V_Fatal,'No smallsets for m68k');
-                                   end
-                                  else
-                                   op:=A_OR;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                begin
-                                  op:=A_ADD;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                   symdifn : begin
-                               { the symetric diff is only for sets }
-                               if is_set then
-                                begin
-                                  op:=A_EOR;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                CGMessage(type_e_mismatch);
-                             end;
-                      muln : begin
-                               if is_set then
-                                begin
-                                  op:=A_AND;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                end
-                               else
-                                begin
-                                  if unsigned then
-                                   op:=A_MULU
-                                  else
-                                   op:=A_MULS;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                      subn : begin
-                               if is_set then
-                                begin
-                                  op:=A_AND;
-                                  mboverflow:=false;
-                                  unsigned:=false;
-                                  extra_not:=true;
-                                end
-                               else
-                                begin
-                                  op:=A_SUB;
-                                  mboverflow:=true;
-                                end;
-                             end;
-                  ltn,lten,
-                  gtn,gten,
-           equaln,unequaln : begin
-                               op:=A_CMP;
-                               cmpop:=true;
-                             end;
-                      xorn : op:=A_EOR;
-                       orn : op:=A_OR;
-                      andn : op:=A_AND;
-                   else
-                     CGMessage(type_e_mismatch);
-                   end;
-
-                   { left and right no register?  }
-                   { then one must be demanded    }
-                   if (p^.left^.location.loc<>LOC_REGISTER) and
-                      (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        { register variable ? }
-                        if (p^.left^.location.loc=LOC_CREGISTER) then
-                          begin
-                             { it is OK if this is the destination }
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-                             else
-                             if cmpop then
-                               begin
-                                  { do not disturb the register }
-                                  hregister:=p^.location.register;
-                               end
-                             else
-                               begin
-                                  hregister:=getregister32;
-                                  emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
-                                    hregister);
-                               end
-                          end
-                        else
-                          begin
-                             del_reference(p^.left^.location.reference);
-                             if is_in_dest then
-                               begin
-                                  hregister:=p^.location.register;
-                                  exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,
-                                    newreference(p^.left^.location.reference),hregister)));
-                               end
-                             else
-                               begin
-                                  hregister:=getregister32;
-                                  { first give free, then demand new register }
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,
-                                   newreference(p^.left^.location.reference),hregister)));
-                               end;
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end
-                   else
-                     { if on the right the register then swap }
-                     if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then
-                       begin
-                          swap_location(p^.location,p^.right^.location);
-
-                          { newly swapped also set swapped flag }
-                          p^.swaped:=not(p^.swaped);
-                       end;
-                   { at this point, p^.location.loc should be LOC_REGISTER }
-                   { and p^.location.register should be a valid register   }
-                   { containing the left result                            }
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if p^.right^.location.loc=LOC_CREGISTER then
-                               begin
-                                  if extra_not then
-                                    exprasmlist^.concat(new(paicpu,op_reg(A_NOT,opsize,p^.location.register)));
-
-                                  emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,R_D6);
-                                  emit_reg_reg(op,opsize,p^.location.register,R_D6);
-                                  emit_reg_reg(A_MOVE,opsize,R_D6,p^.location.register);
-                               end
-                             else
-                               begin
-                                  if extra_not then
-                                    exprasmlist^.concat(new(paicpu,op_reg(A_NOT,opsize,p^.location.register)));
-
-                                  exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,
-                                    newreference(p^.right^.location.reference),R_D6)));
-                                  exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,p^.location.register,R_D6)));
-                                  exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,opsize,R_D6,p^.location.register)));
-                                  del_reference(p^.right^.location.reference);
-                               end;
-                          end
-                        else
-                          begin
-                             if (p^.right^.treetype=ordconstn) and (op=A_CMP) and
-                                (p^.right^.value=0) then
-                                  exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,p^.location.register)))
-                             else
-                                if (p^.right^.treetype=ordconstn) and (op=A_MULS) and
-                                   (ispowerof2(p^.right^.value,power)) then
-                                  begin
-                                    if (power <= 8) then
-                                        exprasmlist^.concat(new(paicpu,op_const_reg(A_ASL,opsize,power,
-                                         p^.location.register)))
-                                    else
-                                      begin
-                                        exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,power,
-                                         R_D6)));
-                                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_ASL,opsize,R_D6,
-                                          p^.location.register)))
-                                      end;
-                                  end
-                             else
-                               begin
-                                  if (p^.right^.location.loc=LOC_CREGISTER) then
-                                    begin
-                                       if extra_not then
-                                         begin
-                                            emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D6);
-                                            exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,R_D6)));
-                                            emit_reg_reg(A_AND,S_L,R_D6,
-                                              p^.location.register);
-                                         end
-                                       else
-                                         begin
-                                            if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                                            { Emulation for MC68000 }
-                                            begin
-                                              emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,
-                                                 R_D0);
-                                              emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1);
-                                              emitcall('FPC_LONGMUL',true);
-                                              emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
-                                            end
-                                            else
-                                            if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                                             CGMessage(cg_f_32bit_not_supported_in_68000)
-                                            else
-                                              emit_reg_reg(op,opsize,p^.right^.location.register,
-                                                p^.location.register);
-                                         end;
-                                    end
-                                  else
-                                    begin
-                                       if extra_not then
-                                         begin
-                                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(
-                                              p^.right^.location.reference),R_D6)));
-                                            exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,R_D6)));
-                                            emit_reg_reg(A_AND,S_L,R_D6,
-                                              p^.location.register);
-                                         end
-                                       else
-                                         begin
-                                            if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                                            { Emulation for MC68000 }
-                                            begin
-                                              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE, opsize,
-                                                 newreference(p^.right^.location.reference),R_D1)));
-                                              emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D0);
-                                              emitcall('FPC_LONGMUL',true);
-                                              emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
-                                            end
-                                            else
-                                            if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                                             CGMessage(cg_f_32bit_not_supported_in_68000)
-                                            else
-                                            { When one of the source/destination is a memory reference  }
-                                            { and the operator is EOR, the we must load it into the     }
-                                            { value into a register first since only EOR reg,reg exists }
-                                            { on the m68k                                               }
-                                            if (op=A_EOR) then
-                                              begin
-                                                exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(
-                                                    p^.right^.location.reference),R_D0)));
-                                                exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,R_D0,
-                                                    p^.location.register)));
-                                              end
-                                            else
-                                              exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,newreference(
-                                                p^.right^.location.reference),p^.location.register)));
-                                         end;
-                                       del_reference(p^.right^.location.reference);
-                                    end;
-                               end;
-                          end;
-                     end
-                   else
-                     begin
-                        { when swapped another result register }
-                        if (p^.treetype=subn) and p^.swaped then
-                          begin
-                             if extra_not then
-                               exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));
-
-                             exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,
-                               p^.location.register,p^.right^.location.register)));
-                               swap_location(p^.location,p^.right^.location);
-
-                               { newly swapped also set swapped flag }
-                               { just to maintain ordering           }
-                               p^.swaped:=not(p^.swaped);
-                          end
-                        else
-                          begin
-                             if extra_not then
-                                   exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.right^.location.register)));
-
-                             if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                             { Emulation for MC68000 }
-                             begin
-                               emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,
-                               R_D0);
-                               emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1);
-                               emitcall('FPC_LONGMUL',true);
-                               emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
-                             end
-                             else
-                             if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then
-                              CGMessage(cg_f_32bit_not_supported_in_68000)
-                             else
-
-                               exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,
-                               p^.right^.location.register,
-                               p^.location.register)));
-                          end;
-                       ungetregister32(p^.right^.location.register);
-                     end;
-
-                   if cmpop then
-                     ungetregister32(p^.location.register);
-
-                   { only in case of overflow operations }
-                   { produce overflow code }
-                   if mboverflow then
-                     emitoverflowcheck(p);
-                   { only in case of overflow operations }
-                   { produce overflow code }
-                   { we must put it here directly, because sign of operation }
-                   { is in unsigned VAR!!                                    }
-                end
-              else
-
-              { Char type }
-                if ((p^.left^.resulttype^.deftype=orddef) and
-                    (porddef(p^.left^.resulttype)^.typ=uchar)) then
-                 begin
-                   case p^.treetype of
-                      ltn,lten,gtn,gten,
-                      equaln,unequaln :
-                                cmpop:=true;
-                      else CGMessage(type_e_mismatch);
-                   end;
-                   unsigned:=true;
-                   { left and right no register? }
-                   { the one must be demanded    }
-                   if (p^.location.loc<>LOC_REGISTER) and
-                     (p^.right^.location.loc<>LOC_REGISTER) then
-                     begin
-                        if p^.location.loc=LOC_CREGISTER then
-                          begin
-                             if cmpop then
-                               { do not disturb register }
-                               hregister:=p^.location.register
-                             else
-                               begin
-                                  hregister:=getregister32;
-                                  emit_reg_reg(A_MOVE,S_B,p^.location.register,
-                                    hregister);
-                               end;
-                          end
-                        else
-                          begin
-                             del_reference(p^.location.reference);
-
-                             { first give free then demand new register }
-                             hregister:=getregister32;
-                             exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),
-                               hregister)));
-                          end;
-                        clear_location(p^.location);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=hregister;
-                     end;
-
-                   { now p always a register }
-
-                   if (p^.right^.location.loc=LOC_REGISTER) and
-                      (p^.location.loc<>LOC_REGISTER) then
-                     begin
-                       swap_location(p^.location,p^.right^.location);
-
-                        { newly swapped also set swapped flag }
-                        p^.swaped:=not(p^.swaped);
-                     end;
-                   if p^.right^.location.loc<>LOC_REGISTER then
-                     begin
-                        if p^.right^.location.loc=LOC_CREGISTER then
-                          begin
-                             emit_reg_reg(A_CMP,S_B,
-                                p^.right^.location.register,p^.location.register);
-                          end
-                        else
-                          begin
-                             exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,S_B,newreference(
-                                p^.right^.location.reference),p^.location.register)));
-                             del_reference(p^.right^.location.reference);
-                          end;
-                     end
-                   else
-                     begin
-                        emit_reg_reg(A_CMP,S_B,p^.right^.location.register,
-                          p^.location.register);
-                        ungetregister32(p^.right^.location.register);
-                     end;
-                   ungetregister32(p^.location.register);
-                end
-              else
-
-              { Floating point }
-               if (p^.left^.resulttype^.deftype=floatdef) and
-                  (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
-                 begin
-                    { real constants to the left }
-                    if p^.left^.treetype=realconstn then
-                     swaptree(p);
-                    cmpop:=false;
-                    case p^.treetype of
-                       addn : op:=A_FADD;
-                       muln : op:=A_FMUL;
-                       subn : op:=A_FSUB;
-                       slashn : op:=A_FDIV;
-                       ltn,lten,gtn,gten,
-                       equaln,unequaln : begin
-                                            op:=A_FCMP;
-                                            cmpop:=true;
-                                         end;
-                       else CGMessage(type_e_mismatch);
-                    end;
-
-                    if (p^.left^.location.loc <> LOC_FPU) and
-                       (p^.right^.location.loc <> LOC_FPU) then
-                      begin
-                         { we suppose left in reference }
-                         del_reference(p^.left^.location.reference);
-                         { get a copy, since we don't want to modify the same }
-                         { node at the same time.                             }
-                         tmpref:=p^.left^.location.reference;
-                         if assigned(p^.left^.location.reference.symbol) then
-                           tmpref.symbol:=stringdup(p^.left^.location.reference.symbol^);
-
-                         floatload(pfloatdef(p^.left^.resulttype)^.typ, tmpref,
-                           p^.left^.location);
-                         clear_reference(tmpref);
-                      end
-                    else
-                      begin
-                        if (p^.right^.location.loc = LOC_FPU)
-                        and(p^.left^.location.loc <> LOC_FPU) then
-                           begin
-                             swap_location(p^.left^.location, p^.right^.location);
-                             p^.swaped := not(p^.swaped);
-                           end
-                      end;
-
-                   { ---------------- LEFT = LOC_FPUREG -------------------- }
-                       if ((p^.treetype =subn) or (p^.treetype = slashn)) and (p^.swaped) then
-                          {  fpu_reg =  right(FP1) / fpu_reg }
-                          {  fpu_reg = right(FP1) -  fpu_reg  }
-                          begin
-                             if (cs_fp_emulation in aktmoduleswitches) then
-                              begin
-                               { fpu_reg = right / D1 }
-                               { fpu_reg = right - D1 }
-                                  exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
-
-
-                                  { load value into D1 }
-                                  if p^.right^.location.loc <> LOC_FPU then
-                                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                       newreference(p^.right^.location.reference),R_D1)))
-                                  else
-                                     emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D1);
-
-                                  { probably a faster way to do this but... }
-                                  case op of
-                                   A_FADD: emitcall('FPC_SINGLE_ADD',true);
-                                   A_FMUL: emitcall('FPC_SINGLE_MUL',true);
-                                   A_FSUB: emitcall('FPC_SINGLE_SUB',true);
-                                   A_FDIV: emitcall('FPC_SINGLE_DIV',true);
-                                   A_FCMP: emitcall('FPC_SINGLE_CMP',true);
-                                  end;
-                                  if not cmpop then { only flags are affected with cmpop }
-                                     exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,
-                                       p^.left^.location.fpureg)));
-
-                                  { if this was a reference, then delete as it }
-                                  { it no longer required.                     }
-                                  if p^.right^.location.loc <> LOC_FPU then
-                                     del_reference(p^.right^.location.reference);
-                              end
-                             else
-                              begin
-
-                                  if p^.right^.location.loc <> LOC_FPU then
-                                    exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,
-                                       getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
-                                      newreference(p^.right^.location.reference),
-                                      R_FP1)))
-                                  else
-                                    { FPm --> FPn must use extended precision }
-                                    emit_reg_reg(A_FMOVE,S_FX,p^.right^.location.fpureg,R_FP1);
-
-                                  { arithmetic expression performed in extended mode }
-                                  exprasmlist^.concat(new(paicpu,op_reg_reg(op,S_FX,
-                                      p^.left^.location.fpureg,R_FP1)));
-
-                                  { cmpop does not change any floating point register!! }
-                                  if not cmpop then
-                                       emit_reg_reg(A_FMOVE,S_FX,R_FP1,p^.left^.location.fpureg)
-{                                       exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,
-                                       getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
-                                       R_FP1,p^.left^.location.fpureg)))}
-                                  else
-                                  { process comparison, to make it compatible with the rest of the code }
-                                      processcc(p);
-
-                                  { if this was a reference, then delete as it }
-                                  { it no longer required.                     }
-                                  if p^.right^.location.loc <> LOC_FPU then
-                                     del_reference(p^.right^.location.reference);
-                              end;
-                          end
-                       else { everything is in the right order }
-                         begin
-                           {  fpu_reg = fpu_reg / right }
-                           {  fpu_reg = fpu_reg - right }
-                           { + commutative ops }
-                           if cs_fp_emulation in aktmoduleswitches then
-                           begin
-
-                             { load value into D7 }
-                             if p^.right^.location.loc <> LOC_FPU then
-                               exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                 newreference(p^.right^.location.reference),R_D0)))
-                             else
-                               emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D0);
-
-                             emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D1);
-                             { probably a faster way to do this but... }
-                             case op of
-                               A_FADD: emitcall('FPC_SINGLE_ADD',true);
-                               A_FMUL: emitcall('FPC_SINGLE_MUL',true);
-                               A_FSUB: emitcall('FPC_SINGLE_SUB',true);
-                               A_FDIV: emitcall('FPC_SINGLE_DIV',true);
-                               A_FCMP: emitcall('FPC_SINGLE_CMP',true);
-                             end;
-                             if not cmpop then { only flags are affected with cmpop }
-                               exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,
-                                 p^.left^.location.fpureg)));
-                             { if this was a reference, then delete as it }
-                             { it no longer required.                     }
-                             if p^.right^.location.loc <> LOC_FPU then
-                               del_reference(p^.right^.location.reference);
-                           end
-                           else
-                           begin
-                             if p^.right^.location.loc <> LOC_FPU then
-                               exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,
-                                 getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
-                                 newreference(p^.right^.location.reference),R_FP1)))
-                             else
-                               emit_reg_reg(A_FMOVE,getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
-                                 p^.right^.location.fpureg,R_FP1);
-
-                               emit_reg_reg(op,S_FX,R_FP1,p^.left^.location.fpureg);
-
-                               if cmpop then
-                                 processcc(p);
-
-                             { if this was a reference, then delete as it }
-                             { it no longer required.                     }
-                             if p^.right^.location.loc <> LOC_FPU then
-                               del_reference(p^.right^.location.reference);
-
-                           end
-                         end; { endif treetype = .. }
-
-
-                         if cmpop then
-                          begin
-                             { the register is now longer required }
-                             if p^.left^.location.loc = LOC_FPU then
-                              begin
-                                ungetregister(p^.left^.location.fpureg);
-                              end;
-
-
-                             if p^.swaped then
-                                 case p^.treetype of
-                                     equaln: flags := F_E;
-                                     unequaln: flags := F_NE;
-                                     ltn : flags := F_G;
-                                     lten : flags := F_GE;
-                                     gtn : flags := F_L;
-                                     gten: flags := F_LE;
-                                 end
-                             else
-                                 case p^.treetype of
-                                     equaln: flags := F_E;
-                                     unequaln : flags := F_NE;
-                                     ltn: flags := F_L;
-                                     lten : flags := F_LE;
-                                     gtn : flags := F_G;
-                                     gten: flags := F_GE;
-                                 end;
-                             clear_location(p^.location);
-                             p^.location.loc := LOC_FLAGS;
-                             p^.location.resflags := flags;
-                             cmpop := false;
-                          end
-                         else
-                         begin
-                             clear_location(p^.location);
-                             p^.location.loc := LOC_FPU;
-                             if p^.left^.location.loc = LOC_FPU then
-                             { copy fpu register result . }
-                             { HERE ON EXIT FPU REGISTER IS IN EXTENDED MODE! }
-                                p^.location.fpureg := p^.left^.location.fpureg
-                             else
-                             begin
-                               InternalError(34);
-                             end;
-                         end;
-                 end
-
-
-              else CGMessage(type_e_mismatch);
-           end;
-       SetResultLocation(cmpop,unsigned,p);
-    end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kcal.pas

@@ -1,1079 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for in call nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-{$ifdef FPC}
-  {$goto on}
-{$endif FPC}
-unit cg68kcal;
-interface
-
-    uses
-      symtable,tree;
-
-    { save the size of pushed parameter }
-    var
-       pushedparasize : longint;
-
-    procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
-                push_from_left_to_right : boolean);
-    procedure secondcalln(var p : ptree);
-    procedure secondprocinline(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k,cg68kld;
-
-{*****************************************************************************
-                             SecondCallParaN
-*****************************************************************************}
-
-
-    procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
-                push_from_left_to_right : boolean);
-
-      procedure maybe_push_open_array_high;
-        var
-           r : preference;
-        begin
-           { open array ? }
-           { defcoll^.data can be nil for read/write }
-           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;
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)));
-                 end
-                else
-                 push_int(parraydef(p^.left^.resulttype)^.highrange-parraydef(p^.left^.resulttype)^.lowrange);
-             end;
-        end;
-
-      var
-         size : longint;
-         stackref : treference;
-         otlabel,hlabel,oflabel : pasmlabel;
-         { temporary variables: }
-         reg : tregister;
-         tempdeftype : tdeftype;
-         tempreference : treference;
-         r : preference;
-         s : topsize;
-         op : tasmop;
-
-      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);
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         secondpass(p^.left);
-         { in codegen.handleread.. defcoll^.data is set to nil }
-         if assigned(defcoll^.data) and
-           (defcoll^.data^.deftype=formaldef) then
-           begin
-              { allow @var }
-              if p^.left^.treetype=addrn then
-                begin
-                   { allways a register }
-                   exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH)));
-                   ungetregister32(p^.left^.location.register);
-                end
-              else
-                begin
-                   if (p^.left^.location.loc<>LOC_REFERENCE) and
-                      (p^.left^.location.loc<>LOC_MEM) then
-                     CGMessage(type_e_mismatch)
-                   else
-                     begin
-                        emitpushreferenceaddr(exprasmlist,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
-           begin
-              if (p^.left^.location.loc<>LOC_REFERENCE) then
-                CGMessage(cg_e_var_must_be_reference);
-              maybe_push_open_array_high;
-              inc(pushedparasize,4);
-              emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-              del_reference(p^.left^.location.reference);
-           end
-         else
-           begin
-              tempdeftype:=p^.resulttype^.deftype;
-              if tempdeftype=filedef then
-               CGMessage(cg_e_file_must_call_by_reference);
-              if (assigned(defcoll^.data) and
-                  is_open_array(defcoll^.data)) or
-                 push_addr_param(p^.resulttype) then
-                begin
-                   maybe_push_open_array_high;
-                   inc(pushedparasize,4);
-                   emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                   del_reference(p^.left^.location.reference);
-                end
-              else
-                case p^.left^.location.loc of
-                   LOC_REGISTER,
-                   LOC_CREGISTER : begin
-                                   { HERE IS A BIG PROBLEM }
-                                   { --> We *MUST* know the data size to push     }
-                                   { for the moment, we can say that the savesize }
-                                   { indicates the parameter size to push, but    }
-                                   { that is CERTAINLY NOT TRUE!                  }
-                                   { CAN WE USE LIKE LOC_MEM OR LOC_REFERENCE??   }
-                                     case integer(p^.left^.resulttype^.size) of
-                                     1 : Begin
-                                     { A byte sized value normally increments       }
-                                     { the SP by 2, BUT because how memory has      }
-                                     { been setup OR because of GAS, a byte sized   }
-                                     { push CRASHES the Amiga, therefore, we do it  }
-                                     { by hand instead.                             }
-                                     {  PUSH A WORD SHIFTED LEFT 8                  }
-                                           reg := getregister32;
-                                           emit_reg_reg(A_MOVE, S_B, p^.left^.location.register, reg);
-                                           exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W,
-                                             8, reg)));
-                                           exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,
-                                            reg,R_SPPUSH)));
-                                           { offset will be TWO greater              }
-                                           inc(pushedparasize,2);
-                                           ungetregister32(reg);
-                                           ungetregister32(p^.left^.location.register);
-                                         end;
-                                     2 :
-                                              Begin
-                                                 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,
-                                                   p^.left^.location.register,R_SPPUSH)));
-                                                 inc(pushedparasize,2);
-                                                 ungetregister32(p^.left^.location.register);
-                                              end;
-                                      4 : Begin
-                                             exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-                                                 p^.left^.location.register,R_SPPUSH)));
-                                             inc(pushedparasize,4);
-                                             ungetregister32(p^.left^.location.register);
-                                          end;
-                                      else
-                                       Begin
-                                         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-                                           p^.left^.location.register,R_SPPUSH)));
-                                         inc(pushedparasize,4);
-                                         ungetregister32(p^.left^.location.register);
-                                       end;
-                                     end; { end case }
-                                   end;
-                   LOC_FPU : begin
-                                        size:=pfloatdef(p^.left^.resulttype)^.size;
-                                        inc(pushedparasize,size);
-                                        { how now how long a FPU is !! }
-                                        if (size > 0) and (size < 9) then
-                                          exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_L,size,R_SP)))
-                                        else
-                                          exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBA,
-                                            S_L,size,R_SP)));
-                                        new(r);
-                                        reset_reference(r^);
-                                        r^.base:=R_SP;
-                                        s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ);
-                                        if (cs_fp_emulation in aktmoduleswitches) or (s=S_FS) then
-                                        begin
-                                          { when in emulation mode... }
-                                          { only single supported!!!  }
-                                          exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,
-                                             p^.left^.location.fpureg,r)));
-                                        end
-                                        else
-                                          { convert back from extended to normal type }
-                                          exprasmlist^.concat(new(paicpu,op_reg_ref(A_FMOVE,s,
-                                             p^.left^.location.fpureg,r)));
-                                     end;
-                   LOC_REFERENCE,LOC_MEM :
-                               begin
-                                  tempreference:=p^.left^.location.reference;
-                                  del_reference(p^.left^.location.reference);
-                                  case p^.resulttype^.deftype of
-                                    enumdef,
-                                     orddef : begin
-                                                   case p^.resulttype^.size of
-                                                    4 : begin
-                                                           emit_push_mem(tempreference);
-                                                           inc(pushedparasize,4);
-                                                        end;
-                                                    1 : Begin
-                                                          { We push a BUT, the SP is incremented by 2      }
-                                                          { as specified in the Motorola Prog's Ref Manual }
-                                                          { Therefore offet increments BY 2!!!             }
-                                                          { BUG??? ...                                     }
-                                                          { SWAP OPERANDS:                                 }
-                                                          if tempreference.isintvalue then
-                                                          Begin
-                                                            exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,
-                                                             tempreference.offset shl 8,R_SPPUSH)));
-                                                          end
-                                                          else
-                                                          Begin
-                                                           { A byte sized value normally increments       }
-                                                           { the SP by 2, BUT because how memory has      }
-                                                           { been setup OR because of GAS, a byte sized   }
-                                                           { push CRASHES the Amiga, therefore, we do it  }
-                                                           { by hand instead.                             }
-                                                           {  PUSH A WORD SHIFTED LEFT 8                  }
-                                                            reg:=getregister32;
-                                                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,
-                                                             newreference(tempreference),reg)));
-                                                            exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W,
-                                                             8, reg)));
-                                                            exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,
-                                                             reg,R_SPPUSH)));
-                                                            ungetregister32(reg);
-{                                                           exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,
-                                                             newreference(tempreference),R_SPPUSH))); }
-                                                          end;
-                                                          inc(pushedparasize,2);
-                                                        end;
-                                                    2 : begin
-                                                          exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,
-                                                            newreference(tempreference),R_SPPUSH)));
-                                                          inc(pushedparasize,2);
-                                                        end;
-                                                   end;
-                                              end;
-                                     floatdef : begin
-                                                   case pfloatdef(p^.resulttype)^.typ of
-                                                      f32bit,
-                                                      s32real :
-                                                        begin
-                                                           emit_push_mem(tempreference);
-                                                           inc(pushedparasize,4);
-                                                        end;
-                                                      s64real:
-                                                      {s64bit }
-                                                                begin
-                                                                   inc(tempreference.offset,4);
-                                                                   emit_push_mem(tempreference);
-                                                                   dec(tempreference.offset,4);
-                                                                   emit_push_mem(tempreference);
-                                                                   inc(pushedparasize,8);
-                                                                end;
-{$ifdef use48}
-                                                      s48real : begin
-                                                                end;
-{$endif}
-                                                      s80real : begin
-                                                                    CGMessage(cg_f_extended_cg68k_not_supported);
-{                                                                   inc(tempreference.offset,6);
-                                                                   emit_push_mem(tempreference);
-                                                                   dec(tempreference.offset,4);
-                                                                   emit_push_mem(tempreference);
-                                                                   dec(tempreference.offset,2);
-                                                                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,
-                                                                     newreference(tempreference),R_SPPUSH)));
-                                                                   inc(pushedparasize,extended_size);}
-                                                                end;
-                                                   end;
-                                                end;
-                                     pointerdef,procvardef,
-                                         classrefdef:  begin
-                                                      emit_push_mem(tempreference);
-                                                      inc(pushedparasize,4);
-                                                   end;
-                                     arraydef,recorddef,stringdef,setdef,objectdef :
-                                                begin
-                                                   if ((p^.resulttype^.deftype=setdef) and
-                                                     (psetdef(p^.resulttype)^.settype=smallset)) then
-                                                     begin
-                                                        emit_push_mem(tempreference);
-                                                        inc(pushedparasize,4);
-                                                     end
-                                                   else
-                                                     begin
-                                                        size:=p^.resulttype^.size;
-
-                                                        { Alignment }
-                                                        {
-                                                        if (size>=4) and ((size and 3)<>0) then
-                                                          inc(size,4-(size and 3))
-                                                        else if (size>=2) and ((size and 1)<>0) then
-                                                          inc(size,2-(size and 1))
-                                                        else
-                                                        if size=1 then size:=2;
-                                                        }
-                                                        { create stack space }
-                                                        if (size > 0) and (size < 9) then
-                                                            exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_L,size,R_SP)))
-                                                        else
-                                                            exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBA,
-                                                              S_L,size,R_SP)));
-                                                        inc(pushedparasize,size);
-                                                        { create stack reference }
-                                                        stackref.symbol := nil;
-                                                        clear_reference(stackref);
-                                                        stackref.base:=R_SP;
-                                                        { produce copy }
-                                                        if p^.resulttype^.deftype=stringdef then
-                                                          begin
-                                                             copystring(stackref,p^.left^.location.reference,
-                                                               pstringdef(p^.resulttype)^.len);
-                                                          end
-                                                        else
-                                                          begin
-                                                             concatcopy(p^.left^.location.reference,
-                                                             stackref,p^.resulttype^.size,true);
-                                                          end;
-                                                     end;
-                                                end;
-                                     else CGMessage(cg_e_illegal_expression);
-                                  end;
-                               end;
-                 LOC_JUMP     : begin
-                                   getlabel(hlabel);
-                                   inc(pushedparasize,2);
-                                   emitl(A_LABEL,truelabel);
-                                   exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,1 shl 8,R_SPPUSH)));
-                                   emitl(A_JMP,hlabel);
-                                   emitl(A_LABEL,falselabel);
-                                   exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,0,R_SPPUSH)));
-                                   emitl(A_LABEL,hlabel);
-                                end;
-                 LOC_FLAGS    : begin
-                                   exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.left^.location.resflags],S_B,
-                                     R_D0)));
-                                   exprasmlist^.concat(new(paicpu,op_reg(A_NEG, S_B, R_D0)));
-                                   exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_W,$ff, R_D0)));
-                                   inc(pushedparasize,2);
-                                   { ----------------- HACK ----------------------- }
-                                   { HERE IS THE BYTE SIZED PUSH HACK ONCE AGAIN    }
-                                   { SHIFT LEFT THE BYTE TO MAKE IT WORK!           }
-                                   exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W,8, R_D0)));
-                                   exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH)));
-                                end;
-                end;
-           end;
-         truelabel:=otlabel;
-         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);
-      end;
-
-
-{*****************************************************************************
-                             SecondCallN
-*****************************************************************************}
-
-    procedure secondcalln(var p : ptree);
-
-      var
-         unusedregisters : tregisterset;
-         pushed : tpushed;
-         funcretref : treference;
-         hregister : tregister;
-         oldpushedparasize : longint;
-         { true if a5 must be loaded again after the subroutine }
-         loada5 : boolean;
-         { true if a virtual method must be called directly }
-         no_virtual_call : boolean;
-         { true if we produce a con- or destrutor in a call }
-         is_con_or_destructor : boolean;
-         { true if a constructor is called again }
-         extended_new : boolean;
-         { adress returned from an I/O-error }
-         iolabel : pasmlabel;
-         { lexlevel count }
-         i : longint;
-         { help reference pointer }
-         r : preference;
-         pp,params : ptree;
-         { temp register allocation }
-         reg: tregister;
-         { help reference pointer }
-         ref: preference;
-
-      label
-         dont_call;
-
-      begin
-         extended_new:=false;
-         iolabel:=nil;
-         loada5:=true;
-         no_virtual_call:=false;
-         unusedregisters:=unused;
-         if not assigned(p^.procdefinition) then
-           exit;
-         { only if no proc var }
-         if not(assigned(p^.right)) then
-           is_con_or_destructor:=(potype_constructor=p^.procdefinition^.proctypeoption)
-             or (potype_destructor=p^.procdefinition^.proctypeoption);
-         { proc variables destroy all registers }
-         if (p^.right=nil) and
-         { virtual methods too }
-           (po_virtualmethod in p^.procdefinition^.procoptions) then
-           begin
-              if (po_iocheck in p^.procdefinition^.procoptions) and
-                 not(po_iocheck in aktprocsym^.definition^.procoptions) and
-                 (cs_check_io in aktlocalswitches) then
-                begin
-                       getlabel(iolabel);
-                   emitl(A_LABEL,iolabel);
-                end
-              else iolabel:=nil;
-
-              { save all used registers }
-              pushusedregisters(pushed,pprocdef(p^.procdefinition)^.usedregisters);
-
-              { give used registers through }
-              usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters;
-           end
-         else
-           begin
-              pushusedregisters(pushed,$ffff);
-              usedinproc:=$ffff;
-
-              { no IO check for methods and procedure variables }
-              iolabel:=nil;
-           end;
-
-         { generate the code for the parameter and push them }
-         oldpushedparasize:=pushedparasize;
-         pushedparasize:=0;
-         if (p^.resulttype<>pdef(voiddef)) and
-            ret_in_param(p^.resulttype) then
-           begin
-              funcretref.symbol:=nil;
-{$ifdef test_dest_loc}
-              if dest_loc_known and (dest_loc_tree=p) and
-                 (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
-                begin
-                   funcretref:=dest_loc.reference;
-                   if assigned(dest_loc.reference.symbol) then
-                     funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
-                   in_dest_loc:=true;
-                end
-              else
-{$endif test_dest_loc}
-              gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref);
-           end;
-         if assigned(p^.left) then
-           begin
-              pushedparasize:=0;
-              { be found elsewhere }
-              if assigned(p^.right) then
-                secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
-                  (pocall_leftright in p^.procdefinition^.proccalloptions))
-              else
-                secondcallparan(p^.left,p^.procdefinition^.para1,
-                  (pocall_leftright in p^.procdefinition^.proccalloptions));
-           end;
-         params:=p^.left;
-         p^.left:=nil;
-         if ret_in_param(p^.resulttype) then
-           begin
-              emitpushreferenceaddr(exprasmlist,funcretref);
-              inc(pushedparasize,4);
-           end;
-         { overloaded operator have no symtable }
-         if (p^.right=nil) then
-           begin
-              { push self }
-              if assigned(p^.symtable) and
-                (p^.symtable^.symtabletype=withsymtable) then
-                begin
-                   { dirty trick to avoid the secondcall below }
-                   p^.methodpointer:=genzeronode(callparan);
-                   p^.methodpointer^.location.loc:=LOC_REGISTER;
-                   p^.methodpointer^.location.register:=R_A5;
-                   { change dispose type !! }
-                   p^.disposetyp:=dt_mbleft_and_method;
-                   { make a reference }
-                   new(r);
-                   reset_reference(r^);
-                   r^.offset:=p^.symtable^.datasize;
-                   r^.base:=procinfo^.framepointer;
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5)));
-                end;
-
-              { push self }
-              if assigned(p^.symtable) and
-                ((p^.symtable^.symtabletype=objectsymtable) or
-                (p^.symtable^.symtabletype=withsymtable)) then
-                begin
-                   if assigned(p^.methodpointer) then
-                     begin
-                        case p^.methodpointer^.treetype of
-                           typen :
-                             begin
-                                { direct call to inherited method }
-                                if po_abstractmethod in p^.procdefinition^.procoptions then
-                                  begin
-                                     CGMessage(cg_e_cant_call_abstract_method);
-                                     goto dont_call;
-                                  end;
-                                { generate no virtual call }
-                                no_virtual_call:=true;
-                                if (sp_static in p^.symtableprocentry^.symoptions) then
-                                 begin
-                                    { well lets put the VMT address directly into a5 }
-                                    { it is kind of dirty but that is the simplest    }
-                                    { way to accept virtual static functions (PM)     }
-                                    loada5:=true;
-                                    exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE,S_L,
-                                      newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5)));
-                                    exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-                                 end
-                               else
-
-                                  { this is a member call, so A5 isn't modfied }
-                                  loada5:=false;
-
-                                    { a class destructor needs a flag }
-                                    if pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                       assigned(aktprocsym) and
-                                       (aktprocsym^.definition^.proctypeoption=potype_destructor) then
-                                      begin
-                                        push_int(0);
-                                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-                                      end;
-
-                                    if not(is_con_or_destructor and
-                                           pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                           assigned(aktprocsym) and
-                                           (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])
-                                          ) then
-                                      exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-                                    { if an inherited con- or destructor should be  }
-                                    { called in a con- or destructor then a warning }
-                                    { will be made                                }
-                                    { con- and destructors need a pointer to the vmt }
-                                    if is_con_or_destructor and
-                                    not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and
-                                    assigned(aktprocsym) then
-                                      begin
-                                         if not(aktprocsym^.definition^.proctypeoption in
-                                                [potype_constructor,potype_destructor]) then
-                                          CGMessage(cg_w_member_cd_call_from_method);
-                                      end;
-                                    { class destructors get there flag below }
-                                    if is_con_or_destructor and
-                                        not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and
-                                        assigned(aktprocsym) and
-                                        (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
-                                       push_int(0);
-                                   end;
-                           hnewn : begin
-                                     { extended syntax of new }
-                                     { A5 must be zero }
-                                     exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,0,R_A5)));
-                                     emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH);
-                                     { insert the vmt }
-                                     exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,
-                                       newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
-                                     extended_new:=true;
-                                  end;
-                           hdisposen : begin
-                                          secondpass(p^.methodpointer);
-
-                                          { destructor with extended syntax called from dispose }
-                                          { hdisposen always deliver LOC_REFRENZ }
-                                          exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-                                            newreference(p^.methodpointer^.location.reference),R_A5)));
-                                          del_reference(p^.methodpointer^.location.reference);
-                                          exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-                                          exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,
-                                            newcsymbol(pobjectdef
-                                               (p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
-                                       end;
-                           else
-                             begin
-                                { call to a instance member }
-                                if (p^.symtable^.symtabletype<>withsymtable) then
-                                  begin
-                                     secondpass(p^.methodpointer);
-
-
-                                     case p^.methodpointer^.location.loc of
-                                        LOC_REGISTER :
-                                           begin
-                                             ungetregister32(p^.methodpointer^.location.register);
-                                             emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5);
-                                           end;
-                                        else
-                                           begin
-                                                 if (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                                   pobjectdef(p^.methodpointer^.resulttype)^.is_class then
-                                                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                                     newreference(p^.methodpointer^.location.reference),R_A5)))
-                                                 else
-                                                  Begin
-                                                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-                                                     newreference(p^.methodpointer^.location.reference),R_A5)));
-                                                  end;
-
-                                                del_reference(p^.methodpointer^.location.reference);
-                                             end;
-                                     end;
-                                  end;
-                                { when calling a class method, we have to load ESI with the VMT !
-                                  But, not for a class method via self }
-                                if not(po_containsself in p^.procdefinition^.procoptions) then
-                                  begin
-                                    if (po_classmethod in p^.procdefinition^.procoptions) and
-                                       not(p^.methodpointer^.resulttype^.deftype=classrefdef) then
-                                  begin
-                                     { class method needs current VMT }
-                                     new(r);
-                                     reset_reference(r^);
-                                     r^.base:=R_A5;
-                                     r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-                                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5)));
-                                  end;
-                                    { direct call to destructor: don't remove data! }
-                                    if (p^.procdefinition^.proctypeoption=potype_destructor) and
-                                       (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                       (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                      push_int(1);
-
-                                    { direct call to class constructor, don't allocate memory }
-                                    if (p^.procdefinition^.proctypeoption=potype_constructor) and
-                                       (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                       (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                      push_int(0)
-                                    else
-                                      exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-                                   if is_con_or_destructor then
-                                   begin
-                                         { classes don't get a VMT pointer pushed }
-                                         if (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                           not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
-                                           begin
-
-                                            if (p^.procdefinition^.proctypeoption=potype_constructor) then
-                                              begin
-                                               { it's no bad idea, to insert the VMT }
-                                                      exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,
-                                               newcsymbol(pobjectdef(
-                                                 p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
-                                              end
-                                            { destructors haven't to dispose the instance, if this is }
-                                            { a direct call                                           }
-                                            else
-                                              push_int(0);
-                                           end;
-                                   end;
-                                  end;
-                             end;
-                        end;
-                     end
-                   else
-                     begin
-                        if (po_classmethod in p^.procdefinition^.procoptions) and
-                          not(
-                            assigned(aktprocsym) and
-                            (po_classmethod in aktprocsym^.definition^.procoptions)
-                          ) then
-                          begin
-                             { class method needs current VMT }
-                             new(r);
-                             reset_reference(r^);
-                             r^.base:=R_A5;
-                             r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-                             exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5)));
-                          end
-                        else
-                          begin
-                             { member call, A5 isn't modified }
-                             loada5:=false;
-                          end;
-                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
-            { but a con- or destructor here would probably almost }
-                        { always be placed wrong }
-                        if is_con_or_destructor then
-                          begin
-                             CGMessage(cg_w_member_cd_call_from_method);
-                             { not insert VMT pointer }                             { VMT-Zeiger nicht eintragen }
-                             push_int(0);
-                          end;
-                     end;
-                end;
-
-              { push base pointer ?}
-              if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and
-            ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then
-                    begin
-                   { if we call a nested function in a method, we must      }
-                   { push also SELF!                                        }
-                   { THAT'S NOT TRUE, we have to load ESI via frame pointer }
-                   { access                                                 }
-                   {
-                     begin
-                        loadesi:=false;
-                        exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ESI)));
-                     end;
-                   }
-                   if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
-                     begin
-                        new(r);
-                        reset_reference(r^);
-                        r^.offset:=procinfo^.framepointer_offset;
-                        r^.base:=procinfo^.framepointer;
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)))
-                     end
-                     { this is only true if the difference is one !!
-                       but it cannot be more !! }
-                   else if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel)-1 then
-                     begin
-                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,procinfo^.framepointer,R_SPPUSH)))
-                     end
-                   else if lexlevel>(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
-                     begin
-                        hregister:=getaddressreg;
-                        new(r);
-                        reset_reference(r^);
-                        r^.offset:=procinfo^.framepointer_offset;
-                        r^.base:=procinfo^.framepointer;
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,hregister)));
-                        for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do
-                          begin
-                             new(r);
-                             reset_reference(r^);
-                             {we should get the correct frame_pointer_offset at each level
-                             how can we do this !!! }
-                             r^.offset:=procinfo^.framepointer_offset;
-                             r^.base:=hregister;
-                             exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,hregister)));
-                          end;
-                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH)));
-                        ungetregister32(hregister);
-                     end
-                   else
-                     internalerror(25000);
-                end;
-
-              if (po_virtualmethod in p^.procdefinition^.procoptions) and
-                 not(no_virtual_call) then
-                begin
-                   { static functions contain the vmt_address in ESI }
-                   { also class methods                              }
-                   if assigned(aktprocsym) then
-                     begin
-                       if (((sp_static in aktprocsym^.symoptions) or
-                        (po_classmethod in aktprocsym^.definition^.procoptions)) and
-                        ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen)))
-                        or
-                        (po_staticmethod in p^.procdefinition^.procoptions) or
-                        (p^.procdefinition^.proctypeoption=potype_constructor) or
-                        { A5 is loaded earlier }
-                        (po_classmethod in p^.procdefinition^.procoptions) then
-                         begin
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_a5;
-                         end
-                       else
-                         begin
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_a5;
-                            r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_a0)));
-                            new(r);
-                            reset_reference(r^);
-                            r^.base:=R_a0;
-                         end;
-                     end
-                   else
-                     begin
-                       new(r);
-                       reset_reference(r^);
-                         r^.base:=R_a5;
-                       exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_a0)));
-                       new(r);
-                       reset_reference(r^);
-                       r^.base:=R_a0;
-                     end;
-                  if pprocdef(p^.procdefinition)^.extnumber=-1 then
-                    internalerror(1609991);
-                  r^.offset:=pprocdef(p^.procdefinition)^.extnumber*4+12;
-                  if (cs_check_range in aktlocalswitches) then
-                    begin
-                     { If the base is already A0, the no instruction will }
-                     { be emitted!                                        }
-                     emit_reg_reg(A_MOVE,S_L,r^.base,R_A0);
-                        emitcall('FPC_CHECK_OBJECT',true);
-                    end;
-                   { This was wrong we must then load the address into the }
-                   { register a0 and/or a5                                 }
-                   { Because doing an indirect call with offset is NOT     }
-                   { allowed on the m68k!                                  }
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(r^),R_A0)));
-                   { clear the reference }
-                   reset_reference(r^);
-                   r^.base := R_A0;
-                  exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,r)));
-                end
-              else if pocall_palmossyscall in p^.procdefinition^.proccalloptions then
-                begin
-                   exprasmlist^.concat(new(paicpu,op_const(A_TRAP,S_NO,15)));
-                   exprasmlist^.concat(new(pai_const,init_16bit(pprocdef(p^.procdefinition)^.extnumber)));
-                end
-              else
-                emitcall(pprocdef(p^.procdefinition)^.mangledname,
-                  (p^.symtableproc^.symtabletype=unitsymtable) or
-                  ((p^.symtableproc^.symtabletype=objectsymtable) and
-                  (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))or
-                  ((p^.symtableproc^.symtabletype=withsymtable) and
-                  (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable)));
-              if (pocall_clearstack in p^.procdefinition^.proccalloptions) then
-                begin
-                   if (pushedparasize > 0) and (pushedparasize < 9) then
-                     { restore the stack, to its initial value }
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP)))
-                   else
-                     { restore the stack, to its initial value }
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP)));
-                end;
-           end
-         else
-           begin
-              secondpass(p^.right);
-              case p^.right^.location.loc of
-                 LOC_REGISTER,
-                 LOC_CREGISTER : begin
-                                   if p^.right^.location.register in [R_D0..R_D7] then
-                                    begin
-                                       reg := getaddressreg;
-                                       emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg);
-                                       new(ref);
-                                       reset_reference(ref^);
-                                       ref^.base := reg;
-                                       exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref)));
-                                       ungetregister(reg);
-                                    end
-                                   else
-                                    begin
-                                        new(ref);
-                                        reset_reference(ref^);
-                                        ref^.base := p^.right^.location.register;
-                                        exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref)));
-                                    end;
-                                   ungetregister32(p^.right^.location.register);
-                                end
-                 else
-                    begin
-                      if assigned(p^.right^.location.reference.symbol) then
-                      { Here we have a symbolic name to the routine, so solve  }
-                      { problem by loading the address first, and then emitting }
-                      { the call.                                              }
-                       begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                           newreference(p^.right^.location.reference),R_A1)));
-                         new(ref);
-                         reset_reference(ref^);
-                         ref^.base := R_A1;
-                         exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref)));
-                       end
-                       else
-                       begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                           newreference(p^.right^.location.reference),R_A1)));
-                         new(ref);
-                         reset_reference(ref^);
-                         ref^.base := R_A1;
-                         exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref)));
-                       end;
-                       del_reference(p^.right^.location.reference);
-                    end;
-              end;
-           end;
-      dont_call:
-         pushedparasize:=oldpushedparasize;
-         unused:=unusedregisters;
-
-         { handle function results }
-         if p^.resulttype<>pdef(voiddef) then
-           begin
-
-              { a contructor could be a function with boolean result }
-              if (p^.right=nil) and
-                 (p^.procdefinition^.proctypeoption=potype_constructor) and
-                 { quick'n'dirty check if it is a class or an object }
-                 (p^.resulttype^.deftype=orddef) then
-                begin
-                   p^.location.loc:=LOC_FLAGS;
-                   p^.location.resflags:=F_NE;
-                   if extended_new then
-                     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
-{$endif test_dest_loc}
-                               hregister:=getregister32;
-                               emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                               p^.location.register:=hregister;
-                     end;
-                end
-              { structed results are easy to handle.... }
-              else if ret_in_param(p^.resulttype) then
-                begin
-                   p^.location.loc:=LOC_MEM;
-                   stringdispose(p^.location.reference.symbol);
-                   p^.location.reference:=funcretref;
-                end
-              else
-                begin
-                   if (p^.resulttype^.deftype in [orddef,enumdef]) then
-                     begin
-                        p^.location.loc:=LOC_REGISTER;
-                  case p^.resulttype^.size of
-                     4 :
-                        begin
-                             hregister:=getregister32;
-                             emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                             p^.location.register:=hregister;
-                        end;
-                     1 :
-                        begin
-                            hregister:=getregister32;
-                            emit_reg_reg(A_MOVE,S_B,R_D0,hregister);
-                            p^.location.register:=hregister;
-                        end;
-                     2:
-                       begin
-                           hregister:=getregister32;
-                           emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                           p^.location.register:=hregister;
-                       end;
-                           else internalerror(7);
-                        end
-                     end
-                   else if (p^.resulttype^.deftype=floatdef) then
-                      case pfloatdef(p^.resulttype)^.typ of
-                           f32bit :
-                              begin
-                                p^.location.loc:=LOC_REGISTER;
-                                hregister:=getregister32;
-                                emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                                p^.location.register:=hregister;
-                      end;
-                     s32real :  Begin
-                                   p^.location.loc:=LOC_FPU;
-                                   hregister:=getregister32;
-                                   emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                                   p^.location.fpureg:=hregister;
-                                end;
-                     s64comp,s64real,s80real: begin
-                                              if cs_fp_emulation in aktmoduleswitches then
-                                              begin
-                                                p^.location.loc:=LOC_FPU;
-                                                hregister:=getregister32;
-                                                emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-                                                p^.location.fpureg:=hregister;
-                                              end
-                                              else
-                                              begin
-                                                { TRUE FPU mode }
-                                                p^.location.loc:=LOC_FPU;
-                                                { on exit of function result in R_FP0 }
-                                                p^.location.fpureg:=R_FP0;
-                                              end;
-                                             end;
-                           else
-                      begin
-                              p^.location.loc:=LOC_FPU;
-                              p^.location.fpureg:=R_FP0;
-                      end;
-             end {end case }
-       else
-        begin
-            p^.location.loc:=LOC_REGISTER;
-            hregister:=getregister32;
-            emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
-            p^.location.register:=hregister;
-                end;
-           end;
-         end;
-         { perhaps i/o check ? }
-         if iolabel<>nil then
-           begin
-              exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,newcsymbol(iolabel^.name,0))));
-              emitcall('FPC_IOCHECK',true);
-           end;
-
-         { restore registers }
-         popusedregisters(pushed);
-
-         { at last, restore instance pointer (SELF) }
-         if loada5 then
-           maybe_loada5;
-         pp:=params;
-         while assigned(pp) do
-           begin
-             if assigned(pp^.left) then
-               if (pp^.left^.location.loc=LOC_REFERENCE) or
-                 (pp^.left^.location.loc=LOC_MEM) then
-                 ungetiftemp(pp^.left^.location.reference);
-               pp:=pp^.right;
-           end;
-         disposetree(params);
-      end;
-
-
-{*****************************************************************************
-                             SecondProcInlineN
-*****************************************************************************}
-
-    procedure secondprocinline(var p : ptree);
-       begin
-         InternalError(132421);
-       end;
-
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kcnv.pas

@@ -1,1368 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for type converting nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-{$ifdef TP}
-  {$E+,F+,N+}
-{$endif}
-unit cg68kcnv;
-interface
-
-    uses
-      tree;
-
-    procedure secondtypeconv(var p : ptree);
-    procedure secondas(var p : ptree);
-    procedure secondis(var p : ptree);
-
-
-implementation
-
-   uses
-     globtype,systems,symconst,
-     cobjects,verbose,globals,
-     symtable,aasm,types,
-     hcodegen,temp_gen,pass_2,
-     cpubase,cga68k,tgen68k;
-
-{*****************************************************************************
-                             SecondTypeConv
-*****************************************************************************}
-
-    procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
-
-      var
-         hp : preference;
-       hregister : tregister;
-       neglabel,poslabel : pasmlabel;
-
-      begin
-         { convert from p2 to p1 }
-         { range check from enums is not made yet !!}
-         { and its probably not easy }
-         if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
-           exit;
-           { range checking is different for u32bit }
-           { lets try to generate it allways }
-           if (cs_check_range in aktlocalswitches)  and
-             { with $R+ explicit type conversations in TP aren't range checked! }
-             (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and
-             ((porddef(p1)^.low>porddef(p2)^.low) or
-             (porddef(p1)^.high<porddef(p2)^.high) or
-             (porddef(p1)^.typ=u32bit) or
-             (porddef(p2)^.typ=u32bit)) then
-           begin
-              porddef(p1)^.genrangecheck;
-              if porddef(p2)^.typ=u8bit then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     begin
-                         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FF,R_D6)));
-                     end
-                   else
-                     begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FF,R_D6)));
-                     end;
-                   hregister:=R_D6;
-                end
-              else if porddef(p2)^.typ=s8bit then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     begin
-                         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
-                         { byte to long }
-                         if aktoptprocessor = MC68020 then
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,R_D6)))
-                         else
-                           begin
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,R_D6)));
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
-                           end;
-                     end
-                   else
-                     begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
-                         { byte to long }
-                         if aktoptprocessor = MC68020 then
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,R_D6)))
-                         else
-                           begin
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,R_D6)));
-                             exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
-                           end;
-                     end; { end outermost else }
-                   hregister:=R_D6;
-                end
-               { rangechecking for u32bit ?? !!!!!!}
-               { lets try }
-               else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit)  then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     hregister:=p^.location.register
-                   else
-                     begin
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),R_D6)));
-                        hregister:=R_D6;
-                     end;
-                end
-              { rangechecking for u32bit ?? !!!!!!}
-              else if porddef(p2)^.typ=u16bit then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
-                   else
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
-                   { unisgned extend }
-                   exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FFFF,R_D6)));
-                   hregister:=R_D6;
-                end
-              else if porddef(p2)^.typ=s16bit then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
-                   else
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
-                   { sign extend }
-                   exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
-                   hregister:=R_D6;
-                end
-              else internalerror(6);
-              new(hp);
-              reset_reference(hp^);
-              hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
-              if porddef(p1)^.low>porddef(p1)^.high then
-                begin
-                   getlabel(neglabel);
-                   getlabel(poslabel);
-                   exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,hregister)));
-                   emitl(A_BLT,neglabel);
-                end;
-              emit_bounds_check(hp^,hregister);
-              if porddef(p1)^.low>porddef(p1)^.high then
-                begin
-                   new(hp);
-                   reset_reference(hp^);
-                   hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
-                   emitl(A_JMP,poslabel);
-                   emitl(A_LABEL,neglabel);
-                   emit_bounds_check(hp^,hregister);
-                   emitl(A_LABEL,poslabel);
-                end;
-           end;
-      end;
-
-
-     type
-        tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
-
-    procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
-      end;
-
-
-    procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         hregister,destregister : tregister;
-         {opsize : topsize;}
-         ref : boolean;
-         hpp : preference;
-
-      begin
-         { !!!!!!!! Rangechecking }
-         ref:=false;
-         { problems with enums !! }
-           { with $R+ explicit type conversations in TP aren't range checked! }
-         if (p^.resulttype^.deftype=orddef) and
-           (hp^.resulttype^.deftype=orddef) and
-           ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or
-           (porddef(p^.resulttype)^.high<porddef(hp^.resulttype)^.high)) then
-           begin
-              if (cs_check_range in aktlocalswitches) and
-                 (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) then
-              porddef(p^.resulttype)^.genrangecheck;
-              if porddef(hp^.resulttype)^.typ=s32bit then
-                begin
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     hregister:=p^.location.register
-                   else
-                     begin
-                        hregister:=getregister32;
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hregister)));
-                     end;
-                end
-              { rangechecking for u32bit ?? !!!!!!}
-              else if porddef(hp^.resulttype)^.typ=u16bit then
-                begin
-                   hregister:=getregister32;
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                   begin
-                     exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)));
-                   end
-                   else
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
-                   { clear unused bits  i.e unsigned extend}
-                   exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, $FFFF, hregister)));
-                end
-              else if porddef(hp^.resulttype)^.typ=s16bit then
-                begin
-                   hregister:=getregister32;
-                   if (p^.location.loc=LOC_REGISTER) or
-                      (p^.location.loc=LOC_CREGISTER) then
-                     exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)))
-                   else
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
-                   { sign extend }
-                   exprasmlist^.concat(new(paicpu,op_reg(A_EXT, S_L, hregister)));
-                end
-              else internalerror(6);
-
-              if (cs_check_range in aktlocalswitches) and
-                 (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) then
-              Begin
-              new(hpp);
-              reset_reference(hpp^);
-              hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
-
-
-              emit_bounds_check(hpp^, hregister);
-              end;
-              clear_location(p^.location);
-              p^.location.loc:=LOC_REGISTER;
-              p^.location.register:=hregister;
-              exit;
-           end
-         { -------------- endian problems once again --------------------}
-         { If RIGHT   enumdef (32-bit) and we do a typecase to a smaller }
-         { type we must absolutely load it into a register first.        }
-         { --------------------------------------------------------------}
-         { ------------ supposing enumdef is always 32-bit --------------}
-         { --------------------------------------------------------------}
-         else
-         if (hp^.resulttype^.deftype = enumdef) and (p^.resulttype^.deftype = orddef) then
-           begin
-              if (hp^.location.loc=LOC_REGISTER) or (hp^.location.loc=LOC_CREGISTER) then
-                 hregister:=hp^.location.register
-              else
-                 begin
-                     hregister:=getregister32;
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(hp^.location.reference),hregister)));
-                 end;
-              clear_location(p^.location);
-              p^.location.loc:=LOC_REGISTER;
-              p^.location.register:=hregister;
-              exit;
-           end;
-         if (p^.left^.location.loc=LOC_REGISTER) or
-           (p^.left^.location.loc=LOC_CREGISTER) then
-           begin
-              { handled by secondpas by called routine ??? }
-              p^.location.register:=p^.left^.location.register;
-           end;
-      end;
-
-
-    procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         hregister : tregister;
-         opsize : topsize;
-         op : tasmop;
-         is_register : boolean;
-
-      begin
-{$ifdef dummy}
-         is_register:=p^.left^.location.loc=LOC_REGISTER;
-           if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
-             begin
-                del_reference(p^.left^.location.reference);
-                { we can do this here as we need no temp inside second_bigger }
-                ungetiftemp(p^.left^.location.reference);
-             end;
-         { this is wrong !!!
-         gives me movl (%eax),%eax
-         for the length(string !!!
-         use only for constant values }
-         {Constanst cannot be loaded into registers using MOVZX!}
-         if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
-             case convtyp of
-                     tc_int_2_int:
-                                 begin
-                                    if is_register then
-                                      hregister := p^.left^.location.register
-                                    else
-                                      hregister := getregister32;
-                                    if is_register then
-                                      emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister)
-                                    else
-                                    begin
-                                      if p^.left^.location.loc = LOC_CREGISTER then
-                                        emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister)
-                                      else
-                                        exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B,
-                                         newreference(P^.left^.location.reference), hregister)));
-                                    end;
-                                    case convtyp of
-                                      tc_u8bit_2_s32bit,
-                                      tc_u8bit_2_u32bit:
-                                                   exprasmlist^.concat(new(paicpu, op_const_reg(
-                                                   A_AND,S_L,$FF,hregister)));
-                                      tc_s8bit_2_u32bit,
-                                      tc_s8bit_2_s32bit:
-                                                  begin
-                                                    if aktoptprocessor = MC68020 then
-                                                      exprasmlist^.concat(new(paicpu,op_reg
-                                                        (A_EXTB,S_L,hregister)))
-                                                    else { else if aktoptprocessor }
-                                                    begin
-                                                    { byte to word }
-                                                      exprasmlist^.concat(new(paicpu,op_reg
-                                                        (A_EXT,S_W,hregister)));
-                                                    { word to long }
-                                                      exprasmlist^.concat(new(paicpu,op_reg
-                                                        (A_EXT,S_L,hregister)));
-                                                    end;
-                                                  end;
-                                      tc_s8bit_2_u16bit,
-                                      tc_u8bit_2_s16bit,
-                                      tc_u8bit_2_u16bit:
-                                                  exprasmlist^.concat(new(paicpu, op_const_reg(
-                                                                A_AND,S_W,$FF,hregister)));
-
-                                      tc_s8bit_2_s16bit:
-                                                  exprasmlist^.concat(new(paicpu, op_reg(
-                                                                A_EXT, S_W, hregister)));
-
-                                    end; { inner case }
-                                   end;
-                tc_u16bit_2_u32bit,
-                tc_u16bit_2_s32bit,
-                tc_s16bit_2_u32bit,
-                tc_s16bit_2_s32bit: begin
-                                     if is_register then
-                                       hregister := p^.left^.location.register
-                                     else
-                                       hregister := getregister32;
-                                     if is_register then
-                                       emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister)
-                                     else
-                                     begin
-                                       if p^.left^.location.loc = LOC_CREGISTER then
-                                         emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister)
-                                       else
-                                         exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_W,
-                                           newreference(P^.left^.location.reference), hregister)));
-                                     end;
-                                     if (convtyp = tc_u16bit_2_s32bit) or
-                                        (convtyp = tc_u16bit_2_u32bit) then
-                                         exprasmlist^.concat(new(paicpu, op_const_reg(
-                                           A_AND, S_L, $ffff, hregister)))
-                                     else { tc_s16bit_2_s32bit }
-                                          { tc_s16bit_2_u32bit }
-                                         exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L,
-                                           hregister)));
-                                    end;
-             end { end case }
-         else
-         begin
-             case convtyp of
-                tc_u8bit_2_s32bit,
-                tc_s8bit_2_s32bit,
-                tc_u16bit_2_s32bit,
-                tc_s16bit_2_s32bit,
-            tc_u8bit_2_u32bit,
-            tc_s8bit_2_u32bit,
-            tc_u16bit_2_u32bit,
-            tc_s16bit_2_u32bit:
-
-                    begin
-                        hregister:=getregister32;
-                        op:=A_MOVE;
-                        opsize:=S_L;
-                    end;
-                tc_s8bit_2_u16bit,
-                tc_s8bit_2_s16bit,
-                tc_u8bit_2_s16bit,
-                tc_u8bit_2_u16bit:
-                    begin
-                        hregister:=getregister32;
-                        op:=A_MOVE;
-                        opsize:=S_W;
-                    end;
-             end;
-            if is_register then
-              begin
-                emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
-              end
-            else
-              begin
-                 if p^.left^.location.loc=LOC_CREGISTER then
-                     emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
-                 else exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,
-                     newreference(p^.left^.location.reference),hregister)));
-              end;
-         end; { end elseif }
-
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=hregister;
-         maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
-{$endif dummy}
-      end;
-
-
-    procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         pushed : tpushed;
-
-      begin
-         { does anybody know a better solution than this big case statement ? }
-         { ok, a proc table would do the job                                  }
-         case pstringdef(p)^.string_typ of
-
-            st_shortstring:
-              case pstringdef(p^.left)^.string_typ of
-                 st_shortstring:
-                   begin
-                      stringdispose(p^.location.reference.symbol);
-                      gettempofsizereference(p^.resulttype^.size,p^.location.reference);
-                      del_reference(p^.left^.location.reference);
-                      copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
-                      ungetiftemp(p^.left^.location.reference);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_longstring:
-              case pstringdef(p^.left)^.string_typ of
-                 st_shortstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_ansistring:
-              case pstringdef(p^.left)^.string_typ of
-                 st_shortstring:
-                   begin
-                      pushusedregisters(pushed,$ff);
-                      push_int(p^.resulttype^.size-1);
-                      gettempofsizereference(p^.resulttype^.size,p^.location.reference);
-                      emitpushreferenceaddr(exprasmlist,p^.location.reference);
-                      case p^.right^.location.loc of
-                         LOC_REGISTER,LOC_CREGISTER:
-                           begin
-                              { !!!!! exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register))); }
-                              ungetregister32(p^.left^.location.register);
-                           end;
-                         LOC_REFERENCE,LOC_MEM:
-                           begin
-                              emit_push_mem(p^.left^.location.reference);
-                              del_reference(p^.left^.location.reference);
-                           end;
-                      end;
-                      emitcall('FPC_ANSI_TO_SHORTSTRING',true);
-                      maybe_loada5;
-                      popusedregisters(pushed);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-
-            st_widestring:
-              case pstringdef(p^.left)^.string_typ of
-                 st_shortstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_ansistring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-                 st_widestring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
-              end;
-         end;
-      end;
-
-    procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=getregister32;
-         inc(p^.left^.location.reference.offset);
-         exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
-           R_A0)));
-         emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
-      end;
-
-    procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         inc(p^.location.reference.offset);
-      end;
-
-    procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         del_reference(p^.left^.location.reference);
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=getregister32;
-         exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
-           R_A0)));
-         emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register);
-      end;
-
-    procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
-      var
-       reg: tregister;
-      begin
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REFERENCE;
-         clear_reference(p^.location.reference);
-         { here, after doing some arithmetic on the pointer }
-         { we put it back in an address register            }
-         if p^.left^.location.loc=LOC_REGISTER then
-         begin
-           reg := getaddressreg;
-           { move the pointer in a data register back into }
-           { an address register.                          }
-           emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg);
-
-           p^.location.reference.base:=reg;
-           ungetregister32(p^.left^.location.register);
-         end
-         else
-           begin
-              if p^.left^.location.loc=LOC_CREGISTER then
-                begin
-                   p^.location.reference.base:=getaddressreg;
-                   emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
-                     p^.location.reference.base);
-                end
-              else
-                begin
-                   del_reference(p^.left^.location.reference);
-                   p^.location.reference.base:=getaddressreg;
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
-                     p^.location.reference.base)));
-                end;
-           end;
-      end;
-
-    { generates the code for the type conversion from an array of char }
-    { to a string                                                        }
-    procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         l : longint;
-
-      begin
-         { this is a type conversion which copies the data, so we can't }
-         { return a reference                                             }
-         clear_location(p^.location);
-         p^.location.loc:=LOC_MEM;
-
-         { first get the memory for the string }
-         stringdispose(p^.location.reference.symbol);
-         gettempofsizereference(256,p^.location.reference);
-
-         { calc the length of the array }
-         l:=parraydef(p^.left^.resulttype)^.highrange-
-           parraydef(p^.left^.resulttype)^.lowrange+1;
-
-         if l>255 then
-           CGMessage(type_e_mismatch);
-
-         { write the length }
-           exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,l,
-             newreference(p^.location.reference))));
-
-         { copy to first char of string }
-         inc(p^.location.reference.offset);
-
-         { generates the copy code      }
-         { and we need the source never }
-         concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
-
-         { correct the string location }
-         dec(p^.location.reference.offset);
-      end;
-
-    procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         stringdispose(p^.location.reference.symbol);
-         gettempofsizereference(256,p^.location.reference);
-      { call loadstring with correct left and right }
-         p^.right:=p^.left;
-         p^.left:=p;
-         loadstring(p);
-         p^.left:=nil; { reset left tree, which is empty }
-         { p^.right is not disposed for typeconv !! PM }
-         disposetree(p^.right);
-         p^.right:=nil;
-      end;
-
-    procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         r : preference;
-
-      begin
-        emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true);
-        ungetiftemp(p^.left^.location.reference);
-        if porddef(p^.left^.resulttype)^.typ=u32bit then
-           push_int(0);
-
-        emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH);
-        new(r);
-        reset_reference(r^);
-        r^.base := R_SP;
-        { no emulation }
-{           for u32bit a solution would be to push $0 and to load a
-+          comp
-+           if porddef(p^.left^.resulttype)^.typ=u32bit then
-+             exprasmlist^.concat(new(paicpu,op_ref(A_FILD,S_IQ,r)))
-+           else}
-          clear_location(p^.location);
-          p^.location.loc := LOC_FPU;
-          { get floating point register. }
-          if (cs_fp_emulation in aktmoduleswitches) then
-          begin
-            p^.location.fpureg := getregister32;
-            exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE, S_L, r, R_D0)));
-            emitcall('FPC_LONG2SINGLE',true);
-            emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg);
-          end
-          else
-          begin
-            p^.location.fpureg := getfloatreg;
-            exprasmlist^.concat(new(paicpu, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg)))
-          end;
-        if porddef(p^.left^.resulttype)^.typ=u32bit then
-           exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,8,R_SP)))
-        else
-        { restore the stack to the previous address }
-           exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L, 4, R_SP)));
-      end;
-
-    procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
-      var
-         rreg : tregister;
-         ref : treference;
-      begin
-         rreg:=getregister32;
-         { Are we in a LOC_FPU, if not then use scratch registers }
-         { instead of allocating reserved registers.              }
-         if (p^.left^.location.loc<>LOC_FPU) then
-         begin
-           if (cs_fp_emulation in aktmoduleswitches) then
-           begin
-             exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0)));
-             exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1)));
-             emitcall('FPC_LONGMUL',true);
-             emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
-           end
-           else
-           begin
-             exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0)));
-             exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,R_FP0)));
-             exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg)));
-           end;
-         end
-         else
-         begin
-           if (cs_fp_emulation in aktmoduleswitches) then
-           begin
-             exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
-             exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1)));
-             emitcall('FPC_LONGMUL',true);
-             emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
-           end
-           else
-           begin
-             exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg)));
-             exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg)));
-           end;
-         end;
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=rreg;
-      end;
-
-
-    procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
-
-      begin
-         case p^.left^.location.loc of
-            LOC_FPU :  begin
-                         { reload }
-                         clear_location(p^.location);
-                         p^.location.loc := LOC_FPU;
-                         p^.location.fpureg := p^.left^.location.fpureg;
-                       end;
-            LOC_MEM,
-            LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ,
-                              p^.left^.location.reference,p^.location);
-         end;
-{ ALREADY HANDLED BY FLOATLOAD      }
-{         p^.location.loc:=LOC_FPU; }
-      end;
-
-    procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
-    var
-        startreg : tregister;
-        hl : pasmlabel;
-        r : treference;
-        reg1: tregister;
-        hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: pasmlabel;
-      begin
-         if (p^.left^.location.loc=LOC_REGISTER) or
-            (p^.left^.location.loc=LOC_CREGISTER) then
-           begin
-              startreg:=p^.left^.location.register;
-              ungetregister(startreg);
-              { move d0,d0 is removed by emit_reg_reg }
-              emit_reg_reg(A_MOVE,S_L,startreg,R_D0);
-           end
-         else
-           begin
-              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(
-                p^.left^.location.reference),R_D0)));
-              del_reference(p^.left^.location.reference);
-              startreg:=R_NO;
-           end;
-
-         reg1 := getregister32;
-
-         { Motorola 68000 equivalent of CDQ     }
-         { we choose d1:d0 pair for quad word   }
-         exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,R_D0)));
-         getlabel(hl1);
-         emitl(A_BPL,hl1);
-         { we copy all bits (-ve number) }
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1)));
-         getlabel(hl2);
-         emitl(A_BRA,hl2);
-         emitl(A_LABEL,hl1);
-         exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_D0)));
-         emitl(A_LABEL,hl2);
-         { end CDQ }
-
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_EOR,S_L,R_D1,R_D0)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,reg1)));
-         getlabel(hl3);
-         emitl(A_BEQ,hl3);
-
-         { Motorola 68000 equivalent of RCL    }
-         getlabel(hl4);
-         emitl(A_BCC,hl4);
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_L,1,reg1)));
-         getlabel(hl5);
-         emitl(A_BRA,hl5);
-         emitl(A_LABEL,hl4);
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1)));
-         emitl(A_LABEL,hl5);
-         { end RCL }
-
-         { Motorola 68000 equivalent of BSR }
-         { save register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_D6)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,31,R_D0)));
-         getlabel(hl6);
-         emitl(A_LABEL,hl6);
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_BTST,S_L,R_D0,R_D1)));
-         getlabel(hl7);
-         emitl(A_BNE,hl7);
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D0)));
-         emitl(A_BPL,hl6);
-         { restore register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D6,R_D0)));
-         emitl(A_LABEL,hl7);
-         { end BSR }
-
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,32,R_D6)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_B,R_D1,R_D6)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D6,R_D0)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_W,1007,R_D1)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,5,R_D1)));
-
-         { Motorola 68000 equivalent of SHLD }
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,11,R_D6)));
-         { save register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D1,R_A0)));
-         getlabel(hl8);
-         emitl(A_LABEL,hl8);
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D1)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6)));
-         emitl(A_BNE,hl8);
-         { restore register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D1)));
-         { end Motorola equivalent of SHLD }
-
-         { Motorola 68000 equivalent of SHLD }
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,20,R_D6)));
-         { save register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_A0)));
-         getlabel(hl9);
-         emitl(A_LABEL,hl9);
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D0)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1)));
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6)));
-         emitl(A_BNE,hl9);
-         { restore register }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D0)));
-         { end Motorola equivalent of SHLD }
-
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,20,R_D6)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_L,R_D6,R_D0)));
-         emitl(A_LABEL, hl3);
-
-         { create temp values and put on stack }
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH)));
-
-
-         reset_reference(r);
-         r.base:=R_SP;
-
-         if (cs_fp_emulation in aktmoduleswitches) then
-         begin
-           clear_location(p^.location);
-           p^.location.loc:=LOC_FPU;
-           p^.location.fpureg := getregister32;
-           exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(r),
-             p^.left^.location.fpureg)))
-         end
-         else
-         begin
-           clear_location(p^.location);
-           p^.location.loc:=LOC_FPU;
-           p^.location.fpureg := getfloatreg;
-           exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(r),
-               p^.left^.location.fpureg)))
-         end;
-         { clear temporary space }
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDQ,S_L,8,R_SP)));
-         ungetregister32(reg1);
-{ Alreadu handled above...          }
-{         p^.location.loc:=LOC_FPU; }
-      end;
-
-    procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         {hs : string;}
-         hregister : tregister;
-
-      begin
-         if (p^.left^.location.loc=LOC_REGISTER) then
-           hregister:=p^.left^.location.register
-         else if (p^.left^.location.loc=LOC_CREGISTER) then
-           hregister:=getregister32
-         else
-           begin
-              del_reference(p^.left^.location.reference);
-              hregister:=getregister32;
-              case porddef(p^.left^.resulttype)^.typ of
-                s8bit : begin
-                           exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B,
-                              newreference(p^.left^.location.reference),hregister)));
-                           if aktoptprocessor = MC68020 then
-                              exprasmlist^.concat(new(paicpu, op_reg(A_EXTB,S_L,hregister)))
-                           else
-                            begin
-                              exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_W,hregister)));
-                              exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L,hregister)));
-                            end;
-                        end;
-                u8bit : begin
-                          exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),
-                            hregister)));
-                          exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hregister)));
-                        end;
-                s16bit :begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
-                           hregister)));
-                          exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,hregister)));
-                        end;
-                u16bit : begin
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
-                               hregister)));
-                            exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hregister)));
-                         end;
-                s32bit,u32bit : exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
-                  hregister)));
-                {!!!! u32bit }
-              end;
-           end;
-         exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ,S_L,16,R_D1)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D1,hregister)));
-
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=hregister;
-      end;
-
-
-     procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);
-
-     begin
-        { secondpass(hp); already done in secondtypeconv PM }
-        clear_location(p^.location);
-        p^.location.loc:=LOC_REGISTER;
-        del_reference(hp^.location.reference);
-        p^.location.register:=getregister32;
-        exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-         newreference(hp^.location.reference),R_A0)));
-
-        emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register);
-     end;
-
-      procedure second_bool_to_int(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         oldtruelabel,oldfalselabel,hlabel : pasmlabel;
-         hregister : tregister;
-         newsize,
-         opsize : topsize;
-         op     : tasmop;
-     begin
-         oldtruelabel:=truelabel;
-         oldfalselabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         secondpass(hp);
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         del_reference(hp^.location.reference);
-         hregister:=getregister32;
-         case porddef(hp^.resulttype)^.typ of
-          bool8bit : begin
-                       case porddef(p^.resulttype)^.typ of
-                     u8bit,s8bit,
-                        bool8bit : opsize:=S_B;
-                   u16bit,s16bit,
-                       bool16bit : opsize:=S_BW;
-                   u32bit,s32bit,
-                       bool32bit : opsize:=S_BL;
-                       end;
-                     end;
-         bool16bit : begin
-                       case porddef(p^.resulttype)^.typ of
-                     u8bit,s8bit,
-                        bool8bit : opsize:=S_B;
-                   u16bit,s16bit,
-                       bool16bit : opsize:=S_W;
-                   u32bit,s32bit,
-                       bool32bit : opsize:=S_WL;
-                       end;
-                     end;
-         bool32bit : begin
-                       case porddef(p^.resulttype)^.typ of
-                     u8bit,s8bit,
-                        bool8bit : opsize:=S_B;
-                   u16bit,s16bit,
-                       bool16bit : opsize:=S_W;
-                   u32bit,s32bit,
-                       bool32bit : opsize:=S_L;
-                       end;
-                     end;
-         end;
-         op:=A_MOVE;
-{         if opsize in [S_B,S_W,S_L] then
-          op:=A_MOVE
-         else
-          if (porddef(p^.resulttype)^.typ in [s8bit,s16bit,s32bit]) then
-           op:=A_MOVSX
-          else
-           op:=A_MOVZX; }
-         case porddef(p^.resulttype)^.typ of
-          bool8bit,u8bit,s8bit : begin
-                                   p^.location.register:=hregister;
-                                   newsize:=S_B;
-                                 end;
-       bool16bit,u16bit,s16bit : begin
-                                   p^.location.register:=hregister;
-                                   newsize:=S_W;
-                                 end;
-       bool32bit,u32bit,s32bit : begin
-                                   p^.location.register:=hregister;
-                                   newsize:=S_L;
-                                 end;
-         else
-          internalerror(10060);
-         end;
-
-         case hp^.location.loc of
-            LOC_MEM,
-      LOC_REFERENCE : exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,
-                        newreference(hp^.location.reference),p^.location.register)));
-       LOC_REGISTER,
-      LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,
-                        hp^.location.register,p^.location.register)));
-          LOC_FLAGS : begin
-{                       hregister:=reg32toreg8(hregister); }
-                        exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
-{ !!!!!!!!
-                        case porddef(p^.resulttype)^.typ of
-                  bool16bit,
-              u16bit,s16bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
-                  bool32bit,
-              u32bit,s32bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
-                        end; }
-                      end;
-           LOC_JUMP : begin
-                        getlabel(hlabel);
-                        emitl(A_LABEL,truelabel);
-                        exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,newsize,1,hregister)));
-                        emitl(A_JMP,hlabel);
-                        emitl(A_LABEL,falselabel);
-                        exprasmlist^.concat(new(paicpu,op_reg(A_CLR,newsize,hregister)));
-                        emitl(A_LABEL,hlabel);
-                      end;
-         else
-           internalerror(10061);
-         end;
-         truelabel:=oldtruelabel;
-         falselabel:=oldfalselabel;
-     end;
-
-
-     procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype);
-     var
-        hregister : tregister;
-     begin
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         del_reference(hp^.location.reference);
-         case hp^.location.loc of
-            LOC_MEM,LOC_REFERENCE :
-              begin
-                hregister:=getregister32;
-                exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                  newreference(hp^.location.reference),hregister)));
-              end;
-            LOC_REGISTER,LOC_CREGISTER :
-              begin
-                hregister:=hp^.location.register;
-              end;
-          else
-            internalerror(10062);
-          end;
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_OR,S_L,hregister,hregister)));
-{        hregister:=reg32toreg8(hregister); }
-         exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
-         case porddef(p^.resulttype)^.typ of
-           bool8bit : p^.location.register:=hregister;
-{ !!!!!!!!!!!
-
-          bool16bit : begin
-                        p^.location.register:=reg8toreg16(hregister);
-                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
-                      end;
-          bool32bit : begin
-                        p^.location.register:=reg16toreg32(hregister);
-                        exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
-                      end; }
-         else
-          internalerror(10064);
-         end;
-     end;
-
-    procedure second_load_smallset(p,hp : ptree;convtyp : tconverttype);
-      var
-        href : treference;
-        pushedregs : tpushed;
-      begin
-        href.symbol:=nil;
-        pushusedregisters(pushedregs,$ff);
-        gettempofsizereference(32,href);
-        emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-        emitpushreferenceaddr(exprasmlist,href);
-        emitcall('FPC_SET_LOAD_SMALL',true);
-        maybe_loada5;
-        popusedregisters(pushedregs);
-        clear_location(p^.location);
-        p^.location.loc:=LOC_MEM;
-        stringdispose(p^.location.reference.symbol);
-        p^.location.reference:=href;
-      end;
-
-    procedure second_ansistring_to_pchar(p,hp : ptree;convtyp : tconverttype);
-
-      var
-         l1,l2 : pasmlabel;
-         hr : preference;
-
-      begin
-        InternalError(342132);
-{!!!!!!!!!!!
-
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         getlabel(l1);
-         getlabel(l2);
-         case hp^.location.loc of
-            LOC_CREGISTER,LOC_REGISTER:
-              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_L,0,
-                hp^.location.register)));
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_L,0,
-                   newreference(hp^.location.reference))));
-                  del_reference(hp^.location.reference);
-                  p^.location.register:=getregister32;
-               end;
-         end;
-         emitl(A_JZ,l1);
-         if hp^.location.loc in [LOC_MEM,LOC_REFERENCE] then
-           exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,newreference(
-             hp^.location.reference),
-             p^.location.register)));
-         emitl(A_JMP,l2);
-         emitl(A_LABEL,l1);
-         new(hr);
-         reset_reference(hr^);
-         hr^.symbol:=stringdup('FPC_EMPTYCHAR');
-         exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,hr,
-           p^.location.register)));
-         emitl(A_LABEL,l2); }
-      end;
-
-    procedure second_pchar_to_string(p,hp : ptree;convtyp : tconverttype);
-      begin
-         internalerror(12121);
-      end;
-
-    procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
-      begin
-      end;
-
-{****************************************************************************
-                             SecondTypeConv
-****************************************************************************}
-
-    procedure secondtypeconv(var p : ptree);
-      const
-         secondconvert : array[tconverttype] of
-           tsecondconvproc = (second_nothing,second_nothing,
-           second_bigger,second_only_rangecheck,
-           second_bigger,second_bigger,second_bigger,
-           second_smaller,second_smaller,
-           second_smaller,second_string_string,
-           second_cstring_charpointer,second_string_chararray,
-           second_array_to_pointer,second_pointer_to_array,
-           second_char_to_string,second_bigger,
-           second_bigger,second_bigger,
-           second_smaller,second_smaller,
-           second_smaller,second_smaller,
-           second_bigger);
-
-{$ifdef dummy}
-           ,second_smaller,
-           second_only_rangecheck,second_bigger,
-           second_bigger,second_bigger,
-           second_bigger,second_only_rangecheck,
-           second_smaller,second_smaller,
-           second_smaller,second_smaller,
-           second_bool_to_int,second_int_to_bool,
-           second_int_real,second_real_fix,
-           second_fix_real,second_int_fix,second_float_float,
-           second_chararray_to_string,
-           second_proc_to_procvar,
-           { is constant char to pchar, is done by firstpass }
-           second_nothing,
-           second_load_smallset,
-           second_ansistring_to_pchar,
-           second_pchar_to_string,
-           second_nothing);
-{$endif dummy}
-
-      begin
-         { this isn't good coding, I think tc_bool_2_int, shouldn't be }
-         { type conversion (FK)                                        }
-
-         { this is necessary, because second_bool_byte, have to change   }
-         { true- and false label before calling secondpass               }
-         if p^.convtyp<>tc_bool_2_int then
-           begin
-              secondpass(p^.left);
-              set_location(p^.location,p^.left^.location);
-              if codegenerror then
-               exit;
-           end;
-
-         if not(p^.convtyp in [tc_equal,tc_not_possible]) then
-           {the second argument only is for maybe_range_checking !}
-           secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
-      end;
-
-
-{*****************************************************************************
-                             SecondIs
-*****************************************************************************}
-
-    procedure secondis(var p : ptree);
-
-      var
-         pushed : tpushed;
-
-      begin
-         { save all used registers }
-         pushusedregisters(pushed,$ffff);
-         secondpass(p^.left);
-         clear_location(p^.location);
-         p^.location.loc:=LOC_FLAGS;
-         p^.location.resflags:=F_NE;
-
-         { push instance to check: }
-         case p^.left^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,
-                   S_L,p^.left^.location.register,R_SPPUSH)));
-                 ungetregister32(p^.left^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,
-                   S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
-                 del_reference(p^.left^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-
-         { generate type checking }
-         secondpass(p^.right);
-         case p^.right^.location.loc of
-            LOC_REGISTER,LOC_CREGISTER:
-              begin
-                 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,
-                   S_L,p^.right^.location.register,R_SPPUSH)));
-                 ungetregister32(p^.right^.location.register);
-              end;
-            LOC_MEM,LOC_REFERENCE:
-              begin
-                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,
-                   S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
-                 del_reference(p^.right^.location.reference);
-              end;
-            else internalerror(100);
-         end;
-         emitcall('FPC_DO_IS',true);
-         exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_B,R_D0)));
-         popusedregisters(pushed);
-      end;
-
-
-{*****************************************************************************
-                             SecondAs
-*****************************************************************************}
-
-    procedure secondas(var p : ptree);
-
-      var
-         pushed : tpushed;
-
-      begin
-         set_location(p^.location,p^.left^.location);
-         { save all used registers }
-         pushusedregisters(pushed,$ffff);
-         { push the vmt of the class }
-         exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE,
-           S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
-         emitpushreferenceaddr(exprasmlist,p^.location.reference);
-          emitcall('FPC_DO_AS',true);
-         popusedregisters(pushed);
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kcon.pas

@@ -1,381 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for constants
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kcon;
-interface
-
-    uses
-      tree;
-
-{.$define SMALLSETORD}
-
-
-    procedure secondrealconst(var p : ptree);
-    procedure secondfixconst(var p : ptree);
-    procedure secondordconst(var p : ptree);
-    procedure secondstringconst(var p : ptree);
-    procedure secondsetconst(var p : ptree);
-    procedure secondniln(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k,symconst;
-
-{*****************************************************************************
-                             SecondRealConst
-*****************************************************************************}
-
-    procedure secondrealconst(var p : ptree);
-      const
-        floattype2ait:array[tfloattype] of tait=
-          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_none,ait_none);
-      var
-         hp1 : pai;
-         lastlabel : pasmlabel;
-         realait : tait;
-      begin
-         lastlabel:=nil;
-         realait:=floattype2ait[pfloatdef(p^.resulttype)^.typ];
-         { const already used ? }
-         if not assigned(p^.lab_real) then
-           begin
-              { tries to found an old entry }
-              hp1:=pai(consts^.first);
-              while assigned(hp1) do
-                begin
-                   if hp1^.typ=ait_label then
-                     lastlabel:=pai_label(hp1)^.l
-                   else
-                     begin
-                        if (hp1^.typ=realait) and (lastlabel<>nil) then
-                          begin
-                             if(
-                                ((realait=ait_real_32bit) and (pai_real_32bit(hp1)^.value=p^.value_real)) or
-                                ((realait=ait_real_64bit) and (pai_real_64bit(hp1)^.value=p^.value_real)) or
-                                ((realait=ait_real_80bit) and (pai_real_80bit(hp1)^.value=p^.value_real)) or
-                                ((realait=ait_comp_64bit) and (pai_comp_64bit(hp1)^.value=p^.value_real))
-                               ) then
-                              begin
-                                  { found! }
-                                  p^.lab_real:=lastlabel;
-                                  break;
-                               end;
-                          end;
-                        lastlabel:=nil;
-                     end;
-                   hp1:=pai(hp1^.next);
-                end;
-              { :-(, we must generate a new entry }
-              if not assigned(p^.lab_real) then
-                begin
-                   getdatalabel(lastlabel);
-                   p^.lab_real:=lastlabel;
-                   if (cs_create_smart in aktmoduleswitches) then
-                    consts^.concat(new(pai_cut,init));
-                   consts^.concat(new(pai_label,init(lastlabel)));
-                   case realait of
-                     ait_real_64bit : consts^.concat(new(pai_real_32bit,init(p^.value_real)));
-                     ait_real_32bit : consts^.concat(new(pai_real_32bit,init(p^.value_real)));
-                     ait_real_80bit : consts^.concat(new(pai_real_32bit,init(p^.value_real)));
-                   else
-                     internalerror(10120);
-                   end;
-                end;
-           end;
-         clear_reference(p^.location.reference);
-         p^.location.reference.symbol:=stringdup(p^.lab_real^.name);
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             SecondFixConst
-*****************************************************************************}
-
-    procedure secondfixconst(var p : ptree);
-      begin
-         { an fix comma const. behaves as a memory reference }
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.isintvalue:=true;
-         p^.location.reference.offset:=p^.value_fix;
-      end;
-
-
-{*****************************************************************************
-                             SecondOrdConst
-*****************************************************************************}
-
-    procedure secondordconst(var p : ptree);
-      begin
-         { an integer const. behaves as a memory reference }
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.isintvalue:=true;
-         p^.location.reference.offset:=p^.value;
-      end;
-
-
-{*****************************************************************************
-                             SecondStringConst
-*****************************************************************************}
-
-    procedure secondstringconst(var p : ptree);
-      var
-         hp1 : pai;
-         l1,l2,
-         lastlabel   : pasmlabel;
-         pc          : pchar;
-         same_string : boolean;
-         i,mylength  : longint;
-      begin
-         lastlabel:=nil;
-         { const already used ? }
-         if not assigned(p^.lab_str) then
-           begin
-              if is_shortstring(p^.resulttype) then
-               mylength:=p^.length+2
-              else
-               mylength:=p^.length+1;
-              { tries to found an old entry }
-              hp1:=pai(consts^.first);
-              while assigned(hp1) do
-                begin
-                   if hp1^.typ=ait_label then
-                     lastlabel:=pai_label(hp1)^.l
-                   else
-                     begin
-                        { when changing that code, be careful that }
-                        { you don't use typed consts, which are    }
-                        { are also written to consts               }
-                        { currently, this is no problem, because   }
-                        { typed consts have no leading length or   }
-                        { they have no trailing zero               }
-                        if (hp1^.typ=ait_string) and (lastlabel<>nil) and
-                           (pai_string(hp1)^.len=mylength) then
-                          begin
-                             same_string:=true;
-                             for i:=0 to p^.length do
-                               if pai_string(hp1)^.str[i]<>p^.value_str[i] then
-                                 begin
-                                    same_string:=false;
-                                    break;
-                                 end;
-                             if same_string then
-                               begin
-                                  { found! }
-                                  p^.lab_str:=lastlabel;
-                                  break;
-                               end;
-                          end;
-                        lastlabel:=nil;
-                     end;
-                   hp1:=pai(hp1^.next);
-                end;
-              { :-(, we must generate a new entry }
-              if not assigned(p^.lab_str) then
-                begin
-                   getdatalabel(lastlabel);
-                   p^.lab_str:=lastlabel;
-                   if (cs_create_smart in aktmoduleswitches) then
-                    consts^.concat(new(pai_cut,init));
-                   consts^.concat(new(pai_label,init(lastlabel)));
-                   { generate an ansi string ? }
-                   case p^.stringtype of
-                      st_ansistring:
-                        begin
-                           { an empty ansi string is nil! }
-                           if p^.length=0 then
-                             consts^.concat(new(pai_const,init_32bit(0)))
-                           else
-                             begin
-                                getdatalabel(l1);
-                                getdatalabel(l2);
-                                consts^.concat(new(pai_label,init(l2)));
-                                consts^.concat(new(pai_const_symbol,init(l1)));
-                                consts^.concat(new(pai_const,init_32bit(p^.length)));
-                                consts^.concat(new(pai_const,init_32bit(p^.length)));
-                                consts^.concat(new(pai_const,init_32bit(-1)));
-                                consts^.concat(new(pai_label,init(l1)));
-                                getmem(pc,p^.length+2);
-                                move(p^.value_str^,pc^,p^.length);
-                                pc[p^.length]:=#0;
-                                { to overcome this problem we set the length explicitly }
-                                { with the ending null char }
-                                consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1)));
-                                { return the offset of the real string }
-                                p^.lab_str:=l2;
-                             end;
-                        end;
-                      st_shortstring:
-                        begin
-                           { empty strings }
-                           if p^.length=0 then
-                            consts^.concat(new(pai_const,init_16bit(0)))
-                           else
-                            begin
-                              { also length and terminating zero }
-                              getmem(pc,p^.length+3);
-                              move(p^.value_str^,pc[1],p^.length+1);
-                              pc[0]:=chr(p^.length);
-                              { to overcome this problem we set the length explicitly }
-                              { with the ending null char }
-                              pc[p^.length+1]:=#0;
-                              consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+2)));
-                            end;
-                        end;
-                   end;
-                end;
-           end;
-         clear_reference(p^.location.reference);
-         p^.location.reference.symbol:=stringdup(p^.lab_str^.name);
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             SecondSetCons
-*****************************************************************************}
-
-    procedure secondsetconst(var p : ptree);
-      var
-         hp1         : pai;
-         lastlabel   : pasmlabel;
-         i           : longint;
-         neededtyp   : tait;
-      begin
-{$ifdef SMALLSETORD}
-        { small sets are loaded as constants }
-        if psetdef(p^.resulttype)^.settype=smallset then
-         begin
-           p^.location.loc:=LOC_MEM;
-           p^.location.reference.isintvalue:=true;
-           p^.location.reference.offset:=plongint(p^.value_set)^;
-           exit;
-         end;
-{$endif}
-        if psetdef(p^.resulttype)^.settype=smallset then
-         neededtyp:=ait_const_32bit
-        else
-         neededtyp:=ait_const_8bit;
-        lastlabel:=nil;
-        { const already used ? }
-        if not assigned(p^.lab_set) then
-          begin
-             { tries to found an old entry }
-             hp1:=pai(consts^.first);
-             while assigned(hp1) do
-               begin
-                  if hp1^.typ=ait_label then
-                    lastlabel:=pai_label(hp1)^.l
-                  else
-                    begin
-                      if (lastlabel<>nil) and (hp1^.typ=neededtyp) then
-                        begin
-                          if (hp1^.typ=ait_const_8bit) then
-                           begin
-                             { compare normal set }
-                             i:=0;
-                             while assigned(hp1) and (i<32) do
-                              begin
-                                if pai_const(hp1)^.value<>p^.value_set^[i] then
-                                 break;
-                                inc(i);
-                                hp1:=pai(hp1^.next);
-                              end;
-                             if i=32 then
-                              begin
-                                { found! }
-                                p^.lab_set:=lastlabel;
-                                break;
-                              end;
-                             { leave when the end of consts is reached, so no
-                               hp1^.next is done }
-                             if not assigned(hp1) then
-                              break;
-                           end
-                          else
-                           begin
-                             { compare small set }
-                             if plongint(p^.value_set)^=pai_const(hp1)^.value then
-                              begin
-                                { found! }
-                                p^.lab_set:=lastlabel;
-                                break;
-                              end;
-                           end;
-                        end;
-                      lastlabel:=nil;
-                    end;
-                  hp1:=pai(hp1^.next);
-               end;
-             { :-(, we must generate a new entry }
-             if not assigned(p^.lab_set) then
-               begin
-                 getdatalabel(lastlabel);
-                 p^.lab_set:=lastlabel;
-                 if (cs_create_smart in aktmoduleswitches) then
-                  consts^.concat(new(pai_cut,init));
-                 consts^.concat(new(pai_label,init(lastlabel)));
-                 if psetdef(p^.resulttype)^.settype=smallset then
-                  begin
-                    move(p^.value_set^,i,sizeof(longint));
-                    consts^.concat(new(pai_const,init_32bit(i)));
-                  end
-                 else
-                  begin
-                    for i:=0 to 31 do
-                      consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
-                  end;
-               end;
-          end;
-        clear_reference(p^.location.reference);
-        p^.location.reference.symbol:=stringdup(p^.lab_set^.name);
-        p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             SecondNilN
-*****************************************************************************}
-
-    procedure secondniln(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-         p^.location.reference.isintvalue:=true;
-         p^.location.reference.offset:=0;
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kflw.pas

@@ -1,782 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for nodes that influence the flow
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-{$ifdef FPC}
-  {$goto on}
-{$endif FPC}
-unit cg68kflw;
-interface
-
-    uses
-      tree;
-
-    procedure second_while_repeatn(var p : ptree);
-    procedure secondifn(var p : ptree);
-    procedure secondfor(var p : ptree);
-    procedure secondexitn(var p : ptree);
-    procedure secondbreakn(var p : ptree);
-    procedure secondcontinuen(var p : ptree);
-    procedure secondgoto(var p : ptree);
-    procedure secondlabel(var p : ptree);
-    procedure secondraise(var p : ptree);
-    procedure secondtryexcept(var p : ptree);
-    procedure secondtryfinally(var p : ptree);
-    procedure secondon(var p : ptree);
-    procedure secondfail(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k;
-
-{*****************************************************************************
-                         Second_While_RepeatN
-*****************************************************************************}
-
-    procedure second_while_repeatn(var p : ptree);
-
-      var
-         l1,l2,l3,oldclabel,oldblabel : pasmlabel;
-         otlabel,oflabel : pasmlabel;
-      begin
-         getlabel(l1);
-         getlabel(l2);
-         { arrange continue and breaklabels: }
-         oldclabel:=aktcontinuelabel;
-         oldblabel:=aktbreaklabel;
-         if p^.treetype=repeatn then
-           begin
-              emitl(A_LABEL,l1);
-              aktcontinuelabel:=l1;
-              aktbreaklabel:=l2;
-              cleartempgen;
-              if assigned(p^.right) then
-               secondpass(p^.right);
-
-              otlabel:=truelabel;
-              oflabel:=falselabel;
-              truelabel:=l2;
-              falselabel:=l1;
-              cleartempgen;
-              secondpass(p^.left);
-              maketojumpbool(p^.left);
-              emitl(A_LABEL,l2);
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-           end
-         else { //// NOT a small set  //// }
-           begin
-              { handling code at the end as it is much more efficient }
-              emitl(A_JMP,l2);
-
-              emitl(A_LABEL,l1);
-              cleartempgen;
-
-              getlabel(l3);
-              aktcontinuelabel:=l2;
-              aktbreaklabel:=l3;
-
-              if assigned(p^.right) then
-               secondpass(p^.right);
-
-              emitl(A_LABEL,l2);
-              otlabel:=truelabel;
-              oflabel:=falselabel;
-              truelabel:=l1;
-              falselabel:=l3;
-              cleartempgen;
-              secondpass(p^.left);
-              maketojumpbool(p^.left);
-
-              emitl(A_LABEL,l3);
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-           end;
-         aktcontinuelabel:=oldclabel;
-         aktbreaklabel:=oldblabel;
-      end;
-
-
-{*****************************************************************************
-                               SecondIfN
-*****************************************************************************}
-
-    procedure secondifn(var p : ptree);
-
-      var
-         hl,otlabel,oflabel : pasmlabel;
-
-      begin
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         cleartempgen;
-         secondpass(p^.left);
-         maketojumpbool(p^.left);
-         if assigned(p^.right) then
-           begin
-              emitl(A_LABEL,truelabel);
-              cleartempgen;
-              secondpass(p^.right);
-           end;
-         if assigned(p^.t1) then
-           begin
-              if assigned(p^.right) then
-                begin
-                   getlabel(hl);
-                   emitl(A_JMP,hl);
-                end;
-              emitl(A_LABEL,falselabel);
-              cleartempgen;
-              secondpass(p^.t1);
-              if assigned(p^.right) then
-                emitl(A_LABEL,hl);
-           end
-         else
-           emitl(A_LABEL,falselabel);
-         if not(assigned(p^.right)) then
-           emitl(A_LABEL,truelabel);
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-      end;
-
-{*****************************************************************************
-                              SecondFor
-*****************************************************************************}
-
-    procedure secondfor(var p : ptree);
-
-      var
-         l1,l3,oldclabel,oldblabel : pasmlabel;
-         omitfirstcomp,temptovalue : boolean;
-         hs : byte;
-         temp1 : treference;
-         hop : tasmop;
-         cmpreg,cmp32 : tregister;
-         opsize : topsize;
-         count_var_is_signed : boolean;
-
-      begin
-         oldclabel:=aktcontinuelabel;
-         oldblabel:=aktbreaklabel;
-         getlabel(aktcontinuelabel);
-         getlabel(aktbreaklabel);
-         getlabel(l3);
-
-         { could we spare the first comparison ? }
-         omitfirstcomp:=false;
-         if p^.right^.treetype=ordconstn then
-           if p^.left^.right^.treetype=ordconstn then
-             omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value))
-               or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value));
-
-         { only calculate reference }
-         cleartempgen;
-         secondpass(p^.t2);
-         if not(simple_loadn) then
-          CGMessage(cg_e_illegal_count_var);
-
-         { produce start assignment }
-         cleartempgen;
-         secondpass(p^.left);
-         count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype));
-         hs:=p^.t2^.resulttype^.size;
-         cmp32:=getregister32;
-         cmpreg:=cmp32;
-         case hs of
-            1 : begin
-                   opsize:=S_B;
-                end;
-            2 : begin
-                   opsize:=S_W;
-                end;
-            4 : begin
-                   opsize:=S_L;
-                end;
-         end;
-         cleartempgen;
-         secondpass(p^.right);
-         { calculate pointer value and check if changeable and if so }
-         { load into temporary variable                              }
-         if p^.right^.treetype<>ordconstn then
-           begin
-              temp1.symbol:=nil;
-              gettempofsizereference(hs,temp1);
-              temptovalue:=true;
-              if (p^.right^.location.loc=LOC_REGISTER) or
-                 (p^.right^.location.loc=LOC_CREGISTER) then
-                begin
-                   exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,opsize,p^.right^.location.register,
-                      newreference(temp1))));
-                 end
-              else
-                 concatcopy(p^.right^.location.reference,temp1,hs,false);
-           end
-         else temptovalue:=false;
-
-         if temptovalue then
-           begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-               begin
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1),
-                     p^.t2^.location.register)));
-                end
-              else
-                begin
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference),
-                     cmpreg)));
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1),
-                     cmpreg)));
-                end;
-           end
-         else
-           begin
-              if not(omitfirstcomp) then
-                begin
-                   if p^.t2^.location.loc=LOC_CREGISTER then
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^.right^.value,
-                       p^.t2^.location.register)))
-                   else
-                     exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,opsize,p^.right^.value,
-               newreference(p^.t2^.location.reference))));
-                end;
-           end;
-         if p^.backward then
-          begin
-           if count_var_is_signed then
-              hop:=A_BLT
-           else
-              hop:=A_BCS;
-          end
-         else
-           if count_var_is_signed then
-             hop:=A_BGT
-           else hop:=A_BHI;
-
-         if not(omitfirstcomp) or temptovalue then
-          emitl(hop,aktbreaklabel);
-
-         emitl(A_LABEL,l3);
-
-         { help register must not be in instruction block }
-         cleartempgen;
-         if assigned(p^.t1) then
-           secondpass(p^.t1);
-
-         emitl(A_LABEL,aktcontinuelabel);
-
-         { makes no problems there }
-         cleartempgen;
-
-         { demand help register again }
-         cmp32:=getregister32;
-         case hs of
-            1 : begin
-                   opsize:=S_B;
-                end;
-            2 : begin
-                   opsize:=S_W;
-                end;
-            4 : opsize:=S_L;
-         end;
-
-     { produce comparison and the corresponding }
-     { jump                                     }
-         if temptovalue then
-           begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-                begin
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1),
-                     p^.t2^.location.register)));
-                end
-              else
-                begin
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference),
-                     cmpreg)));
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1),
-                     cmpreg)));
-                end;
-           end
-         else
-           begin
-              if p^.t2^.location.loc=LOC_CREGISTER then
-                exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^.right^.value,
-                  p^.t2^.location.register)))
-              else
-                exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,opsize,p^.right^.value,
-                  newreference(p^.t2^.location.reference))));
-           end;
-         if p^.backward then
-           if count_var_is_signed then
-             hop:=A_BLE
-           else
-             hop :=A_BLS
-          else
-            if count_var_is_signed then
-              hop:=A_BGE
-            else
-               hop:=A_BCC;
-         emitl(hop,aktbreaklabel);
-         { according to count direction DEC or INC... }
-         { must be after the test because of 0to 255 for bytes !! }
-         if p^.backward then
-           hop:=A_SUB
-         else hop:=A_ADD;
-
-         if p^.t2^.location.loc=LOC_CREGISTER then
-           exprasmlist^.concat(new(paicpu,op_const_reg(hop,opsize,1,p^.t2^.location.register)))
-         else
-            exprasmlist^.concat(new(paicpu,op_const_ref(hop,opsize,1,newreference(p^.t2^.location.reference))));
-         emitl(A_JMP,l3);
-
-     { this is the break label: }
-         emitl(A_LABEL,aktbreaklabel);
-         ungetregister32(cmp32);
-
-         if temptovalue then
-           ungetiftemp(temp1);
-
-         aktcontinuelabel:=oldclabel;
-         aktbreaklabel:=oldblabel;
-      end;
-
-
-{*****************************************************************************
-                              SecondExitN
-*****************************************************************************}
-
-    procedure secondexitn(var p : ptree);
-
-      var
-         is_mem : boolean;
-         {op : tasmop;
-         s : topsize;}
-         otlabel,oflabel : pasmlabel;
-
-      label
-         do_jmp;
-
-      begin
-         if assigned(p^.left) then
-           begin
-              otlabel:=truelabel;
-              oflabel:=falselabel;
-              getlabel(truelabel);
-              getlabel(falselabel);
-              secondpass(p^.left);
-              case p^.left^.location.loc of
-                 LOC_FPU : goto do_jmp;
-                 LOC_MEM,LOC_REFERENCE : is_mem:=true;
-                 LOC_CREGISTER,
-                 LOC_REGISTER : is_mem:=false;
-                 LOC_FLAGS : begin
-                                exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0)));
-                                exprasmlist^.concat(new(paicpu,op_reg(A_NEG, S_B, R_D0)));
-                                goto do_jmp;
-                             end;
-                 LOC_JUMP : begin
-                               emitl(A_LABEL,truelabel);
-                               exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,1,R_D0)));
-                               emitl(A_JMP,aktexit2label);
-                               exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_B,R_D0)));
-                               goto do_jmp;
-                            end;
-                 else internalerror(2001);
-              end;
-              case procinfo^.retdef^.deftype of
-               orddef,
-              enumdef : begin
-                          case procinfo^.retdef^.size of
-                           4 : if is_mem then
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                   newreference(p^.left^.location.reference),R_D0)))
-                               else
-                                 emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0);
-                           2 : if is_mem then
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,
-                                   newreference(p^.left^.location.reference),R_D0)))
-                               else
-                                 emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,R_D0);
-                           1 : if is_mem then
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,
-                                   newreference(p^.left^.location.reference),R_D0)))
-                               else
-                                 emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D0);
-                          end;
-                        end;
-           pointerdef,
-           procvardef : begin
-                          if is_mem then
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                              newreference(p^.left^.location.reference),R_D0)))
-                          else
-                            exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0)));
-                        end;
-             floatdef : begin
-                          { floating point return values .... }
-                          { single are returned in d0         }
-                          if (pfloatdef(procinfo^.retdef)^.typ=f32bit) or
-                             (pfloatdef(procinfo^.retdef)^.typ=s32real) then
-                           begin
-                             if is_mem then
-                               exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                 newreference(p^.left^.location.reference),R_D0)))
-                             else
-                               begin
-                                 if pfloatdef(procinfo^.retdef)^.typ=f32bit then
-                                   emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0)
-                                 else
-                                   begin
-                                      { single values are in the floating point registers }
-                                      if cs_fp_emulation in aktmoduleswitches then
-                                         emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)
-                                      else
-                                         exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_FS,
-                                            p^.left^.location.fpureg,R_D0)));
-                                   end;
-                               end;
-                           end
-                          else
-                           Begin
-                             { this is only possible in real non emulation mode }
-                             { LOC_MEM,LOC_REFERENCE }
-                             if is_mem then
-                              begin
-                                exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,
-                                  getfloatsize(pfloatdef(procinfo^.retdef)^.typ),
-                                    newreference(p^.left^.location.reference),R_FP0)));
-                              end
-                             else
-                             { LOC_FPU }
-                              begin
-                                { convert from extended to correct type }
-                                { when storing                          }
-                                exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,
-                                  getfloatsize(pfloatdef(procinfo^.retdef)^.typ),p^.left^.location.fpureg,R_FP0)));
-                              end;
-                           end;
-                        end;
-              end;
-do_jmp:
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-              emitl(A_JMP,aktexit2label);
-           end
-         else
-           begin
-              emitl(A_JMP,aktexitlabel);
-           end;
-      end;
-
-
-{*****************************************************************************
-                              SecondBreakN
-*****************************************************************************}
-
-    procedure secondbreakn(var p : ptree);
-      begin
-         if aktbreaklabel<>nil then
-           emitl(A_JMP,aktbreaklabel)
-         else
-           CGMessage(cg_e_break_not_allowed);
-      end;
-
-
-{*****************************************************************************
-                              SecondContinueN
-*****************************************************************************}
-
-    procedure secondcontinuen(var p : ptree);
-      begin
-         if aktcontinuelabel<>nil then
-           emitl(A_JMP,aktcontinuelabel)
-         else
-           CGMessage(cg_e_continue_not_allowed);
-      end;
-
-
-{*****************************************************************************
-                             SecondGoto
-*****************************************************************************}
-
-    procedure secondgoto(var p : ptree);
-
-       begin
-         emitl(A_JMP,p^.labelnr);
-       end;
-
-
-{*****************************************************************************
-                             SecondLabel
-*****************************************************************************}
-
-    procedure secondlabel(var p : ptree);
-      begin
-         emitl(A_LABEL,p^.labelnr);
-         cleartempgen;
-         secondpass(p^.left);
-      end;
-
-
-{*****************************************************************************
-                             SecondRaise
-*****************************************************************************}
-
-    { generates the code for a raise statement }
-    procedure secondraise(var p : ptree);
-
-      var
-         a : pasmlabel;
-
-      begin
-         if assigned(p^.left) then
-           begin
-              { generate the address }
-              if assigned(p^.right) then
-                begin
-                   secondpass(p^.right);
-                   if codegenerror then
-                     exit;
-                end
-              else
-                begin
-                   getlabel(a);
-                   emitl(A_LABEL,a);
-                   exprasmlist^.concat(new(paicpu,
-                     op_csymbol_reg(A_MOVE,S_L,newcsymbol(a^.name,0),R_SPPUSH)));
-                end;
-              secondpass(p^.left);
-              if codegenerror then
-                exit;
-
-              case p^.left^.location.loc of
-                 LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                 LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-                   p^.left^.location.register,R_SPPUSH)));
-                 else CGMessage(type_e_mismatch);
-              end;
-              emitcall('FPC_RAISEEXCEPTION',true);
-             end
-           else
-            emitcall('FPC_RERAISE',true);
-      end;
-
-
-{*****************************************************************************
-                             SecondTryExcept
-*****************************************************************************}
-
-    var
-       endexceptlabel : pasmlabel;
-
-    procedure secondtryexcept(var p : ptree);
-
-      var
-         exceptlabel,doexceptlabel,oldendexceptlabel,
-         lastonlabel : pasmlabel;
-
-      begin
-        InternalError(3431243);
-(*
-         { this can be called recursivly }
-         oldendexceptlabel:=endexceptlabel;
-         { we modify EAX }
-         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
-
-         getlabel(exceptlabel);
-         getlabel(doexceptlabel);
-         getlabel(endexceptlabel);
-         getlabel(lastonlabel);
-         push_int (1); { push type of exceptionframe }
-         emitcall('FPC_PUSHEXCEPTADDR',true);
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         emitcall('FPC_SETJMP',true);
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         emitl(A_JNE,exceptlabel);
-
-         { try code }
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-
-         emitl(A_LABEL,exceptlabel);
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_POP,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         emitl(A_JNE,doexceptlabel);
-         emitcall('FPC_POPADDRSTACK',true);
-         emitl(A_JMP,endexceptlabel);
-         emitl(A_LABEL,doexceptlabel);
-
-         if assigned(p^.right) then
-           secondpass(p^.right);
-
-         emitl(A_LABEL,lastonlabel);
-         { default handling }
-         if assigned(p^.t1) then
-           begin
-              { FPC_CATCHES must be called with
-                'default handler' flag (=-1)
-              }
-              push_int (-1);
-              emitcall('FPC_CATCHES',true);
-              secondpass(p^.t1);
-           end
-         else
-           emitcall('FPC_RERAISE',true);
-         emitl(A_LABEL,endexceptlabel);
-         endexceptlabel:=oldendexceptlabel; *)
-      end;
-
-
-{*****************************************************************************
-                             SecondOn
-*****************************************************************************}
-
-    procedure secondon(var p : ptree);
-      var
-         nextonlabel,myendexceptlabel : pasmlabel;
-         ref : treference;
-
-      begin
-{ !!!!!!!!!!!!!!! }
-(*         getlabel(nextonlabel);
-         { push the vmt }
-         exprasmlist^.concat(new(paicpu,op_csymbol(A_PUSH,S_L,
-           newcsymbol(p^.excepttype^.vmt_mangledname,0))));
-         maybe_concat_external(p^.excepttype^.owner,
-           p^.excepttype^.vmt_mangledname);
-
-         emitcall('FPC_CATCHES',true);
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         emitl(A_JE,nextonlabel);
-         ref.symbol:=nil;
-         gettempofsizereference(4,ref);
-
-         { what a hack ! }
-         if assigned(p^.exceptsymtable) then
-           pvarsym(p^.exceptsymtable^.root)^.address:=ref.offset;
-
-         exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
-           R_EAX,newreference(ref))));
-
-         if assigned(p^.right) then
-           secondpass(p^.right);
-         { clear some stuff }
-         ungetiftemp(ref);
-         emitl(A_JMP,endexceptlabel);
-         emitl(A_LABEL,nextonlabel);
-         { next on node }
-         if assigned(p^.left) then
-           secondpass(p^.left); *)
-      end;
-
-{*****************************************************************************
-                             SecondTryFinally
-*****************************************************************************}
-
-    procedure secondtryfinally(var p : ptree);
-
-      var
-         finallylabel,noreraiselabel,endfinallylabel : pasmlabel;
-
-      begin
-(*         { we modify EAX }
-         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
-
-         getlabel(finallylabel);
-         getlabel(noreraiselabel);
-         getlabel(endfinallylabel);
-         push_int(1); { Type of stack-frame must be pushed}
-         emitcall('FPC_PUSHEXCEPTADDR',true);
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         emitcall('FPC_SETJMP',true);
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_PUSH,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         emitl(A_JNE,finallylabel);
-
-         { try code }
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-
-         emitl(A_LABEL,finallylabel);
-
-         { finally code }
-         secondpass(p^.right);
-         if codegenerror then
-           exit;
-         exprasmlist^.concat(new(paicpu,
-           op_reg(A_POP,S_L,R_EAX)));
-         exprasmlist^.concat(new(paicpu,
-           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
-         emitl(A_JE,noreraiselabel);
-         emitcall('FPC_RERAISE',true);
-         emitl(A_LABEL,noreraiselabel);
-         emitcall('FPC_POPADDRSTACK',true);
-         emitl(A_LABEL,endfinallylabel); *)
-      end;
-
-
-{*****************************************************************************
-                             SecondFail
-*****************************************************************************}
-
-    procedure secondfail(var p : ptree);
-      var
-        hp : preference;
-      begin
-         exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_A5)));
-         { also reset to zero in the stack }
-         new(hp);
-         reset_reference(hp^);
-         hp^.offset:=procinfo^.selfpointer_offset;
-         hp^.base:=procinfo^.framepointer;
-         exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A5,hp)));
-         exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kinl.pas

@@ -1,909 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k inline nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kinl;
-interface
-
-    uses
-      tree;
-
-    procedure secondinline(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      aasm,types,symtable,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k,cg68kld,cg68kcal;
-
-
-{*****************************************************************************
-                                Helpers
-*****************************************************************************}
-
-    { reverts the parameter list }
-    var nb_para : integer;
-
-    function reversparameter(p : ptree) : ptree;
-
-       var
-         hp1,hp2 : ptree;
-
-      begin
-         hp1:=nil;
-         nb_para := 0;
-         while assigned(p) do
-           begin
-              { pull out }
-              hp2:=p;
-              p:=p^.right;
-              inc(nb_para);
-              { pull in }
-              hp2^.right:=hp1;
-              hp1:=hp2;
-           end;
-         reversparameter:=hp1;
-       end;
-
-
-{*****************************************************************************
-                             SecondInLine
-*****************************************************************************}
-
-    procedure secondinline(var p : ptree);
-       const
-         { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
-         float_name: array[tfloattype] of string[8]=
-           ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16');
-         addqconstsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADDQ,A_SUBQ);
-         addconstsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
-         addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
-       var
-         aktfile : treference;
-         ft : tfiletype;
-         opsize : topsize;
-         asmop : tasmop;
-         pushed : tpushed;
-         {inc/dec}
-         addconstant : boolean;
-         addvalue : longint;
-
-
-      procedure handlereadwrite(doread,doln : boolean);
-      { produces code for READ(LN) and WRITE(LN) }
-
-        procedure loadstream;
-          const
-            io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
-          var
-            r : preference;
-          begin
-            new(r);
-            reset_reference(r^);
-            r^.symbol:=stringdup(
-            'U_'+upper(target_info.system_unit)+io[byte(doread)]);
-            exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,r,R_A0)))
-          end;
-
-        var
-           node,hp    : ptree;
-           typedtyp,
-           pararesult : pdef;
-           has_length : boolean;
-           dummycoll  : tdefcoll;
-           iolabel    : pasmlabel;
-           npara      : longint;
-
-        begin
-           { I/O check }
-           if (cs_check_io in aktlocalswitches) and
-              not(po_iocheck in aktprocsym^.definition^.procoptions) then
-             begin
-                getlabel(iolabel);
-                emitl(A_LABEL,iolabel);
-             end
-           else
-             iolabel:=nil;
-           { for write of real with the length specified }
-           has_length:=false;
-           hp:=nil;
-           { reserve temporary pointer to data variable }
-           aktfile.symbol:=nil;
-           gettempofsizereference(4,aktfile);
-           { first state text data }
-           ft:=ft_text;
-           { and state a parameter ? }
-           if p^.left=nil then
-             begin
-                { the following instructions are for "writeln;" }
-                loadstream;
-                { save @aktfile in temporary variable }
-                exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
-             end
-           else
-             begin
-                { revers paramters }
-                node:=reversparameter(p^.left);
-
-                p^.left := node;
-                npara := nb_para;
-                { calculate data variable }
-                { is first parameter a file type ? }
-                if node^.left^.resulttype^.deftype=filedef then
-                  begin
-                     ft:=pfiledef(node^.left^.resulttype)^.filetype;
-                     if ft=ft_typed then
-                       typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
-                     secondpass(node^.left);
-                     if codegenerror then
-                       exit;
-
-                     { save reference in temporary variables }
-                     if node^.left^.location.loc<>LOC_REFERENCE then
-                       begin
-                          CGMessage(cg_e_illegal_expression);
-                          exit;
-                       end;
-
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0)));
-
-                     { skip to the next parameter }
-                     node:=node^.right;
-                  end
-                else
-                  begin
-                  { load stdin/stdout stream }
-                     loadstream;
-                  end;
-
-                { save @aktfile in temporary variable }
-                exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
-                if doread then
-                { parameter by READ gives call by reference }
-                  dummycoll.paratyp:=vs_var
-                { an WRITE Call by "Const" }
-                else
-                  dummycoll.paratyp:=vs_const;
-
-                { because of secondcallparan, which otherwise attaches }
-                if ft=ft_typed then
-                  { this is to avoid copy of simple const parameters }
-                  {dummycoll.data:=new(pformaldef,init)}
-                  dummycoll.data:=cformaldef
-                else
-                  { I think, this isn't a good solution (FK) }
-                  dummycoll.data:=nil;
-
-                while assigned(node) do
-                  begin
-                     pushusedregisters(pushed,$ff);
-                     hp:=node;
-                     node:=node^.right;
-                     hp^.right:=nil;
-                     if hp^.is_colon_para then
-                       CGMessage(parser_e_illegal_colon_qualifier);
-                     if ft=ft_typed then
-                       never_copy_const_param:=true;
-                     secondcallparan(hp,@dummycoll,false);
-                     if ft=ft_typed then
-                       never_copy_const_param:=false;
-                     hp^.right:=node;
-                     if codegenerror then
-                       exit;
-
-                     emit_push_mem(aktfile);
-                     if (ft=ft_typed) then
-                       begin
-                          { OK let's try this }
-                          { first we must only allow the right type }
-                          { we have to call blockread or blockwrite }
-                          { but the real problem is that            }
-                          { reset and rewrite should have set       }
-                          { the type size                           }
-                          { as recordsize for that file !!!!        }
-                          { how can we make that                    }
-                          { I think that is only possible by adding }
-                          { reset and rewrite to the inline list a call        }
-                          { allways read only one record by element }
-                            push_int(typedtyp^.size);
-                            if doread then
-                              emitcall('FPC_TYPED_READ',true)
-                            else
-                              emitcall('FPC_TYPED_WRITE',true);
-                       end
-                     else
-                       begin
-                          { save current position }
-                          pararesult:=hp^.left^.resulttype;
-                          { handle possible field width  }
-                          { of course only for write(ln) }
-                          if not doread then
-                            begin
-                               { handle total width parameter }
-                              if assigned(node) and node^.is_colon_para then
-                                begin
-                                   hp:=node;
-                                   node:=node^.right;
-                                   hp^.right:=nil;
-                                   secondcallparan(hp,@dummycoll,false);
-                                   hp^.right:=node;
-                                   if codegenerror then
-                                     exit;
-                                   has_length:=true;
-                                end
-                              else
-                                if pararesult^.deftype<>floatdef then
-                                  push_int(0)
-                                else
-                                  push_int(-32767);
-                            { a second colon para for a float ? }
-                              if assigned(node) and node^.is_colon_para then
-                                begin
-                                   hp:=node;
-                                   node:=node^.right;
-                                   hp^.right:=nil;
-                                   secondcallparan(hp,@dummycoll,false);
-                                   hp^.right:=node;
-                                   if pararesult^.deftype<>floatdef then
-                                     CGMessage(parser_e_illegal_colon_qualifier);
-                                   if codegenerror then
-                                     exit;
-                                end
-                              else
-                                begin
-                                  if pararesult^.deftype=floatdef then
-                                    push_int(-1);
-                                end
-                            end;
-                          case pararesult^.deftype of
-                       stringdef : begin
-                                     if doread then
-                                       begin
-                                       { push maximum string length }
-                                       push_int(pstringdef(pararesult)^.len);
-                                       case pstringdef(pararesult)^.string_typ of
-                                        st_shortstring:
-                                          emitcall ('FPC_READ_TEXT_STRING',true);
-                                        st_ansistring:
-                                          emitcall ('FPC_READ_TEXT_ANSISTRING',true);
-                                        st_longstring:
-                                          emitcall ('FPC_READ_TEXT_LONGSTRING',true);
-                                        st_widestring:
-                                          emitcall ('FPC_READ_TEXT_ANSISTRING',true);
-                                        end
-                                       end
-                                     else
-                                       Case pstringdef(Pararesult)^.string_typ of
-                                        st_shortstring:
-                                          emitcall ('FPC_WRITE_TEXT_STRING',true);
-                                        st_ansistring:
-                                          emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
-                                        st_longstring:
-                                          emitcall ('FPC_WRITE_TEXT_LONGSTRING',true);
-                                        st_widestring:
-                                          emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
-                                        end;
-                                   end;
-                      pointerdef : begin
-                                     if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
-                                       begin
-                                         if doread then
-                                           emitcall('FPC_READ_TEXT_PCHAR_AS_POINTER',true)
-                                         else
-                                           emitcall('FPC_WRITE_TEXT_PCHAR_AS_POINTER',true);
-                                       end;
-                                   end;
-                        arraydef : begin
-                                     if (parraydef(pararesult)^.lowrange=0) and
-                                        is_equal(parraydef(pararesult)^.definition,cchardef) then
-                                       begin
-                                         if doread then
-                                           emitcall('FPC_READ_TEXT_PCHAR_AS_ARRAY',true)
-                                         else
-                                           emitcall('FPC_WRITE_TEXT_PCHAR_AS_ARRAY',true);
-                                       end;
-                                   end;
-                        floatdef : begin
-                                     if doread then
-                                       emitcall('FPC_READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true)
-                                     else
-                                       emitcall('FPC_WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true);
-                                   end;
-                          orddef : begin
-                                     case porddef(pararesult)^.typ of
-                                          u8bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_BYTE',true);
-                                          s8bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_SHORTINT',true);
-                                         u16bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_WORD',true);
-                                         s16bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_INTEGER',true);
-                                         s32bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_LONGINT',true)
-                                                  else
-                                                    emitcall('FPC_WRITE_TEXT_LONGINT',true);
-                                         u32bit : if doread then
-                                                    emitcall('FPC_READ_TEXT_CARDINAL',true)
-                                                  else
-                                                    emitcall('FPC_WRITE_TEXT_CARDINAL',true);
-                                          uchar : if doread then
-                                                    emitcall('FPC_READ_TEXT_CHAR',true)
-                                                  else
-                                                    emitcall('FPC_WRITE_TEXT_CHAR',true);
-                                       bool8bit,
-                                      bool16bit,
-                                      bool32bit : if  doread then
-                                                    CGMessage(parser_e_illegal_parameter_list)
-                                                  else
-                                                    emitcall('FPC_WRITE_TEXT_BOOLEAN',true);
-                                     end;
-                                   end;
-                          end;
-                       end;
-                   { load ESI in methods again }
-                     popusedregisters(pushed);
-                     maybe_loada5;
-                  end;
-             end;
-         { Insert end of writing for textfiles }
-           if ft=ft_text then
-             begin
-               pushusedregisters(pushed,$ff);
-               emit_push_mem(aktfile);
-               if doread then
-                begin
-                  if doln then
-                    emitcall('FPC_READLN_END',true)
-                  else
-                    emitcall('FPC_READ_END',true);
-                end
-               else
-                begin
-                  if doln then
-                    emitcall('FPC_WRITELN_END',true)
-                  else
-                    emitcall('FPC_WRITE_END',true);
-                end;
-               popusedregisters(pushed);
-               maybe_loada5;
-             end;
-         { Insert IOCheck if set }
-           if assigned(iolabel) then
-             begin
-                { registers are saved in the procedure }
-                exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,newcsymbol(iolabel^.name,0))));
-                emitcall('FPC_IOCHECK',true);
-             end;
-         { Freeup all used temps }
-           ungetiftemp(aktfile);
-           if assigned(p^.left) then
-             begin
-                p^.left:=reversparameter(p^.left);
-                if npara<>nb_para then
-                  CGMessage(cg_f_internal_error_in_secondinline);
-                hp:=p^.left;
-                while assigned(hp) do
-                  begin
-                     if assigned(hp^.left) then
-                       if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-                         ungetiftemp(hp^.left^.location.reference);
-                     hp:=hp^.right;
-                  end;
-             end;
-        end;
-
-      procedure handle_str;
-
-        var
-           hp,node : ptree;
-           dummycoll : tdefcoll;
-           is_real,has_length : boolean;
-
-          begin
-           pushusedregisters(pushed,$ff);
-           node:=p^.left;
-           is_real:=false;
-           has_length:=false;
-           while assigned(node^.right) do node:=node^.right;
-           { if a real parameter somewhere then call REALSTR }
-           if (node^.left^.resulttype^.deftype=floatdef) then
-             is_real:=true;
-
-           node:=p^.left;
-           { we have at least two args }
-           { with at max 2 colon_para in between }
-
-           { first arg longint or float }
-           hp:=node;
-           node:=node^.right;
-           hp^.right:=nil;
-           dummycoll.data:=hp^.resulttype;
-           { string arg }
-
-           dummycoll.paratyp:=vs_var;
-           secondcallparan(hp,@dummycoll,false);
-           if codegenerror then
-             exit;
-
-           dummycoll.paratyp:=vs_const;
-           disposetree(hp);
-           p^.left:=nil;
-
-           { second arg }
-           hp:=node;
-           node:=node^.right;
-           hp^.right:=nil;
-           { frac  para }
-           if hp^.is_colon_para and assigned(node) and
-              node^.is_colon_para then
-             begin
-                dummycoll.data:=hp^.resulttype;
-                secondcallparan(hp,@dummycoll,false);
-                if codegenerror then
-                  exit;
-                disposetree(hp);
-                hp:=node;
-                node:=node^.right;
-                hp^.right:=nil;
-                has_length:=true;
-             end
-           else
-             if is_real then
-             push_int(-1);
-
-           { third arg, length only if is_real }
-           if hp^.is_colon_para then
-             begin
-                dummycoll.data:=hp^.resulttype;
-                secondcallparan(hp,@dummycoll,false);
-                if codegenerror then
-                  exit;
-                disposetree(hp);
-                hp:=node;
-                node:=node^.right;
-                hp^.right:=nil;
-             end
-           else
-             if is_real then
-               push_int(-32767)
-             else
-               push_int(-1);
-
-           { last arg longint or real }
-           secondcallparan(hp,@dummycoll,false);
-           if codegenerror then
-             exit;
-
-           disposetree(hp);
-
-           if is_real then
-             emitcall('FPC_STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true)
-           else if porddef(hp^.resulttype)^.typ=u32bit then
-             emitcall('FPC_STR_CARDINAL',true)
-           else
-             emitcall('FPC_STR_LONGINT',true);
-           popusedregisters(pushed);
-        end;
-
-      var
-         r : preference;
-         l : longint;
-         ispushed : boolean;
-         hregister : tregister;
-         otlabel,oflabel,filenamestring : pasmlabel;
-         oldpushedparasize : longint;
-      begin
-      { save & reset pushedparasize }
-         oldpushedparasize:=pushedparasize;
-         pushedparasize:=0;
-         case p^.inlinenumber of
-            in_assert_x_y:
-              begin
-               { !!!!!!!!! }
-              end;
-            in_lo_word,
-            in_hi_word :
-              begin
-                       secondpass(p^.left);
-                       p^.location.loc:=LOC_REGISTER;
-                       if p^.left^.location.loc<>LOC_REGISTER then
-                         begin
-                            if p^.left^.location.loc=LOC_CREGISTER then
-                              begin
-                                 p^.location.register:=getregister32;
-                                 emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,
-                                   p^.location.register);
-                              end
-                            else
-                              begin
-                                 del_reference(p^.left^.location.reference);
-                                 p^.location.register:=getregister32;
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,
-                                  newreference(p^.left^.location.reference),
-                                  p^.location.register)));
-                              end;
-                         end
-                       else p^.location.register:=p^.left^.location.register;
-                       if p^.inlinenumber=in_hi_word then
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_LSR,S_W,8,p^.location.register)));
-                       p^.location.register:=p^.location.register;
-              end;
-            in_high_x :
-              begin
-                 if is_open_array(p^.left^.resulttype) then
-                   begin
-                      secondpass(p^.left);
-                      del_reference(p^.left^.location.reference);
-                      p^.location.register:=getregister32;
-                      new(r);
-                      reset_reference(r^);
-                      r^.base:=highframepointer;
-                      r^.offset:=highoffset+4;
-                      exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                        r,p^.location.register)));
-                   end
-              end;
-            in_sizeof_x,
-            in_typeof_x :
-              begin
-               { sizeof(openarray) handling }
-                 if (p^.inlinenumber=in_sizeof_x) and
-                    is_open_array(p^.left^.resulttype) then
-                  begin
-                  { sizeof(openarray)=high(openarray)+1 }
-                    secondpass(p^.left);
-                    del_reference(p^.left^.location.reference);
-                    p^.location.register:=getregister32;
-                    new(r);
-                    reset_reference(r^);
-                    r^.base:=highframepointer;
-                    r^.offset:=highoffset+4;
-                    exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                      r,p^.location.register)));
-                    exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,
-                      1,p^.location.register)));
-                    if parraydef(p^.left^.resulttype)^.elesize<>1 then
-                      exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_L,
-                        parraydef(p^.left^.resulttype)^.elesize,p^.location.register)));
-                  end
-                 else
-                  begin
-                    { for both cases load vmt }
-                    if p^.left^.treetype=typen then
-                      begin
-                        exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_LEA,
-                          S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0),
-                          R_A0)));
-                        p^.location.register:=getregister32;
-                        emit_reg_reg(A_MOVE,S_L,R_A0,p^.location.register);
-                      end
-                    else
-                      begin
-                        secondpass(p^.left);
-                        del_reference(p^.left^.location.reference);
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.location.register:=getregister32;
-                        { load VMT pointer }
-                        inc(p^.left^.location.reference.offset,
-                          pobjectdef(p^.left^.resulttype)^.vmt_offset);
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                          newreference(p^.left^.location.reference),
-                          p^.location.register)));
-                      end;
-                    { in sizeof load size }
-                    if p^.inlinenumber=in_sizeof_x then
-                      begin
-                         new(r);
-                         reset_reference(r^);
-                        { load the address in A0 }
-                        { because now supposedly p^.location.register is an }
-                        { address.                                          }
-                        emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0);
-                        r^.base:=R_A0;
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,
-                          p^.location.register)));
-                      end;
-                  end;
-              end;
-            in_lo_long,
-            in_hi_long : begin
-                       secondpass(p^.left);
-                       p^.location.loc:=LOC_REGISTER;
-                       if p^.left^.location.loc<>LOC_REGISTER then
-                         begin
-                            if p^.left^.location.loc=LOC_CREGISTER then
-                              begin
-                                 p^.location.register:=getregister32;
-                                 emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
-                                   p^.location.register);
-                              end
-                            else
-                              begin
-                                 del_reference(p^.left^.location.reference);
-                                 p^.location.register:=getregister32;
-                                 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                  newreference(p^.left^.location.reference),
-                                  p^.location.register)));
-                              end;
-                         end
-                       else p^.location.register:=p^.left^.location.register;
-                       if p^.inlinenumber=in_hi_long then
-                         begin
-                           exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ, S_L, 16, R_D1)));
-                           exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register)));
-                         end;
-                       p^.location.register:=p^.location.register;
-                    end;
-            in_length_string :
-              begin
-                 secondpass(p^.left);
-                 set_location(p^.location,p^.left^.location);
-                 { length in ansi strings is at offset -8 }
-                 if is_ansistring(p^.left^.resulttype) then
-                   dec(p^.location.reference.offset,8);
-              end;
-            in_pred_x,
-            in_succ_x:
-              begin
-                 secondpass(p^.left);
-                 if p^.inlinenumber=in_pred_x then
-                   asmop:=A_SUB
-                 else
-                   asmop:=A_ADD;
-                 case p^.resulttype^.size of
-                   4 : opsize:=S_L;
-                   2 : opsize:=S_W;
-                   1 : opsize:=S_B;
-                 else
-                    internalerror(10080);
-                 end;
-                 p^.location.loc:=LOC_REGISTER;
-                 if p^.left^.location.loc<>LOC_REGISTER then
-                   begin
-                      p^.location.register:=getregister32;
-                      if p^.left^.location.loc=LOC_CREGISTER then
-                        emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
-                          p^.location.register)
-                      else
-                      if p^.left^.location.loc=LOC_FLAGS then
-                        exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
-                                  p^.location.register)))
-                      else
-                        begin
-                           del_reference(p^.left^.location.reference);
-                           exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference),
-                             p^.location.register)));
-                        end;
-                   end
-                 else p^.location.register:=p^.left^.location.register;
-                 exprasmlist^.concat(new(paicpu,op_const_reg(asmop,opsize,1,
-                   p^.location.register)))
-                 { here we should insert bounds check ? }
-                 { and direct call to bounds will crash the program }
-                 { if we are at the limit }
-                 { we could also simply say that pred(first)=first and succ(last)=last }
-                 { could this be usefull I don't think so (PM)
-                 emitoverflowcheck;}
-              end;
-            in_dec_x,
-            in_inc_x :
-              begin
-              { set defaults }
-                addvalue:=1;
-                addconstant:=true;
-              { load first parameter, must be a reference }
-                secondpass(p^.left^.left);
-                case p^.left^.left^.resulttype^.deftype of
-                  orddef,
-                 enumdef : begin
-                             case p^.left^.left^.resulttype^.size of
-                              1 : opsize:=S_B;
-                              2 : opsize:=S_W;
-                              4 : opsize:=S_L;
-                             end;
-                           end;
-              pointerdef : begin
-                             opsize:=S_L;
-                             addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.size;
-                           end;
-                else
-                 internalerror(10081);
-                end;
-              { second argument specified?, must be a s32bit in register }
-                if assigned(p^.left^.right) then
-                 begin
-                   secondpass(p^.left^.right^.left);
-                 { when constant, just multiply the addvalue }
-                   if is_constintnode(p^.left^.right^.left) then
-                    addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left)
-                   else
-                    begin
-                      case p^.left^.right^.left^.location.loc of
-                   LOC_REGISTER,
-                  LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register;
-                        LOC_MEM,
-                  LOC_REFERENCE : begin
-                                    hregister:=getregister32;
-                                    exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                      newreference(p^.left^.right^.left^.location.reference),hregister)));
-                                  end;
-                       else
-                        internalerror(10082);
-                       end;
-                    { insert multiply with addvalue if its >1 }
-                      if addvalue>1 then
-                       exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,opsize,
-                         addvalue,hregister)));
-                      addconstant:=false;
-                    end;
-                 end;
-              { write the add instruction }
-                if addconstant then
-                 begin
-                   if (addvalue > 0) and (addvalue < 9) then
-                    exprasmlist^.concat(new(paicpu,op_const_ref(addqconstsubop[p^.inlinenumber],opsize,
-                      addvalue,newreference(p^.left^.left^.location.reference))))
-                   else
-                    exprasmlist^.concat(new(paicpu,op_const_ref(addconstsubop[p^.inlinenumber],opsize,
-                      addvalue,newreference(p^.left^.left^.location.reference))));
-                 end
-                else
-                 begin
-                   exprasmlist^.concat(new(paicpu,op_reg_ref(addsubop[p^.inlinenumber],opsize,
-                      hregister,newreference(p^.left^.left^.location.reference))));
-                   ungetregister32(hregister);
-                 end;
-                emitoverflowcheck(p^.left^.left);
-              end;
-            in_assigned_x :
-              begin
-                secondpass(p^.left^.left);
-                p^.location.loc:=LOC_FLAGS;
-                if (p^.left^.left^.location.loc=LOC_REGISTER) or
-                   (p^.left^.left^.location.loc=LOC_CREGISTER) then
-                 begin
-                   exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,
-                    p^.left^.left^.location.register)));
-                   ungetregister32(p^.left^.left^.location.register);
-                 end
-                else
-                 begin
-                   exprasmlist^.concat(new(paicpu,op_ref(A_TST,S_L,
-                   newreference(p^.left^.left^.location.reference))));
-                   del_reference(p^.left^.left^.location.reference);
-                 end;
-                p^.location.resflags:=F_NE;
-              end;
-             in_reset_typedfile,in_rewrite_typedfile :
-               begin
-                  pushusedregisters(pushed,$ffff);
-                  exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,
-                    pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH)));
-                  secondload(p^.left);
-                  emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                  if p^.inlinenumber=in_reset_typedfile then
-                    emitcall('FPC_RESET_TYPED',true)
-                  else
-                    emitcall('FPC_REWRITE_TYPED',true);
-                  popusedregisters(pushed);
-               end;
-            in_write_x :
-              handlereadwrite(false,false);
-            in_writeln_x :
-              handlereadwrite(false,true);
-            in_read_x :
-              handlereadwrite(true,false);
-            in_readln_x :
-              handlereadwrite(true,true);
-            in_str_x_string :
-              begin
-                 handle_str;
-                 maybe_loada5;
-              end;
-            in_include_x_y,
-            in_exclude_x_y:
-              begin
-                 CGMessage(cg_e_include_not_implemented);
-{ !!!!!!!  }
-(*               secondpass(p^.left^.left);
-                 if p^.left^.right^.left^.treetype=ordconstn then
-                   begin
-                      { calculate bit position }
-                      l:=1 shl (p^.left^.right^.left^.value mod 32);
-
-                      { determine operator }
-                      if p^.inlinenumber=in_include_x_y then
-                        asmop:=A_OR
-                      else
-                        begin
-                           asmop:=A_AND;
-                           l:=not(l);
-                        end;
-                      if (p^.left^.left^.location.loc=LOC_REFERENCE) then
-                        begin
-                           inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4);
-                           exprasmlist^.concat(new(paicpu,op_const_ref(asmop,S_L,
-                             l,newreference(p^.left^.left^.location.reference))));
-                           del_reference(p^.left^.left^.location.reference);
-                        end
-                      else
-                        { LOC_CREGISTER }
-                        exprasmlist^.concat(new(paicpu,op_const_reg(asmop,S_L,
-                          l,p^.left^.left^.location.register)));
-                   end
-                 else
-                   begin
-                      { generate code for the element to set }
-                      ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left);
-                      secondpass(p^.left^.right^.left);
-                      if ispushed then
-                        restore(p^.left^.left);
-                      { determine asm operator }
-                      if p^.inlinenumber=in_include_x_y then
-                        asmop:=A_BTS
-                      else
-                        asmop:=A_BTR;
-                      if psetdef(p^.left^.resulttype)^.settype=smallset then
-                        begin
-                           if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
-                             hregister:=p^.left^.right^.left^.location.register
-                           else
-                             begin
-                                hregister:=R_EDI;
-                                exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,
-                                  newreference(p^.left^.right^.left^.location.reference),R_EDI)));
-                             end;
-                          if (p^.left^.left^.location.loc=LOC_REFERENCE) then
-                            exprasmlist^.concat(new(paicpu,op_reg_ref(asmop,S_L,R_EDI,
-                              newreference(p^.left^.right^.left^.location.reference))))
-                          else
-                            exprasmlist^.concat(new(paicpu,op_reg_reg(asmop,S_L,R_EDI,
-                              p^.left^.right^.left^.location.register)));
-                        end
-                      else
-                        begin
-                           internalerror(10083);
-                        end;
-                   end;
-                   *)
-               end;
-
-         else
-           internalerror(9);
-         end;
-         pushedparasize:=oldpushedparasize;
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:36  michael
-  + removed logs
-
-}

compiler/old/cg68kld.pas

@@ -1,480 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for load/assignment nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kld;
-interface
-
-    uses
-      tree,cpubase;
-
-    var
-       { this is for open arrays and strings        }
-       { but be careful, this data is in the        }
-       { generated code destroyed quick, and also   }
-       { the next call of secondload destroys this  }
-       { data                                       }
-       { So be careful using the informations       }
-       { provided by this variables                 }
-       highframepointer : tregister;
-       highoffset : longint;
-
-    procedure secondload(var p : ptree);
-    procedure secondassignment(var p : ptree);
-    procedure secondfuncret(var p : ptree);
-    procedure secondarrayconstruct(var p : ptree);
-
-
-implementation
-
-    uses
-      cobjects,verbose,globals,symconst,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cga68k,tgen68k;
-
-
-{*****************************************************************************
-                             SecondLoad
-*****************************************************************************}
-
-    procedure secondload(var p : ptree);
-
-      var
-         hregister : tregister;
-         i : longint;
-         symtabletype: tsymtabletype;
-         hp : preference;
-
-      begin
-         simple_loadn:=true;
-         reset_reference(p^.location.reference);
-         case p^.symtableentry^.typ of
-              { this is only for toasm and toaddr }
-              absolutesym :
-                 begin
-                    stringdispose(p^.location.reference.symbol);
-                    p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
-                 end;
-              varsym :
-                 begin
-                    hregister:=R_NO;
-                    symtabletype:=p^.symtable^.symtabletype;
-                    { in case it is a register variable: }
-                    { we simply set the location to the  }
-                    { correct register.                  }
-                    if pvarsym(p^.symtableentry)^.reg<>R_NO then
-                      begin
-                         p^.location.loc:=LOC_CREGISTER;
-                         p^.location.register:=pvarsym(p^.symtableentry)^.reg;
-                         unused:=unused-[pvarsym(p^.symtableentry)^.reg];
-                      end
-                    else
-                      begin
-                         { --------------------- LOCAL AND TEMP VARIABLES ------------- }
-                         if (symtabletype=parasymtable) or (symtabletype=localsymtable) then
-                           begin
-
-                              p^.location.reference.base:=procinfo^.framepointer;
-                              p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
-
-                              if (symtabletype=localsymtable) then
-                                p^.location.reference.offset:=-p^.location.reference.offset;
-
-                              if (symtabletype in [localsymtable,inlinelocalsymtable]) then
-                                p^.location.reference.offset:=-p^.location.reference.offset;
-
-                              if (lexlevel>(p^.symtable^.symtablelevel)) then
-                                begin
-                                   hregister:=getaddressreg;
-
-                                   { make a reference }
-                                   new(hp);
-                                   reset_reference(hp^);
-                                   hp^.offset:=procinfo^.framepointer_offset;
-                                   hp^.base:=procinfo^.framepointer;
-
-                                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister)));
-
-                                   simple_loadn:=false;
-                                   i:=lexlevel-1;
-                                   while i>(p^.symtable^.symtablelevel) do
-                                     begin
-                                        { make a reference }
-                                        new(hp);
-                                        reset_reference(hp^);
-                                        hp^.offset:=8;
-                                        hp^.base:=hregister;
-
-                                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister)));
-                                        dec(i);
-                                     end;
-                                   p^.location.reference.base:=hregister;
-                                end;
-                           end
-                         { --------------------- END OF LOCAL AND TEMP VARS ---------------- }
-                         else
-                           case symtabletype of
-                              unitsymtable,globalsymtable,
-                              staticsymtable : begin
-                                                  stringdispose(p^.location.reference.symbol);
-                                                  p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
-                                               end;
-                              objectsymtable : begin
-                                                  if sp_static in pvarsym(p^.symtableentry)^.symoptions then
-                                                    begin
-                                                       stringdispose(p^.location.reference.symbol);
-                                                       p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
-                                                    end
-                                                  else
-                                                    begin
-                                                  p^.location.reference.base:=R_A5;
-                                                  p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
-                                               end;
-                                               end;
-                              withsymtable :   begin
-                                                  hregister:=getaddressreg;
-                                                  p^.location.reference.base:=hregister;
-                                                  { make a reference }
-                                                  new(hp);
-                                                  reset_reference(hp^);
-                                                  hp^.offset:=p^.symtable^.datasize;
-                                                  hp^.base:=procinfo^.framepointer;
-
-                                                  exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister)));
-
-                                                  p^.location.reference.offset:=
-                                                    pvarsym(p^.symtableentry)^.address;
-                                               end;
-                           end;
-
-                         { in case call by reference, then calculate: }
-                         if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
-                            is_open_array(pvarsym(p^.symtableentry)^.definition) or
-                            is_array_of_const(pvarsym(p^.symtableentry)^.definition) or
-                            ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
-                             push_addr_param(pvarsym(p^.symtableentry)^.definition)) then
-                           begin
-                              simple_loadn:=false;
-                              if hregister=R_NO then
-                                hregister:=getaddressreg;
-                              { ADDED FOR OPEN ARRAY SUPPORT. }
-                              if (p^.location.reference.base=procinfo^.framepointer) then
-                                begin
-                                   highframepointer:=p^.location.reference.base;
-                                   highoffset:=p^.location.reference.offset;
-                                end
-                              else
-                                begin
-                                   highframepointer:=R_A1;
-                                   highoffset:=p^.location.reference.offset;
-                                   exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-                                     p^.location.reference.base,R_A1)));
-                                end;
-                              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
-                                hregister)));
-                              { END ADDITION }
-                              clear_reference(p^.location.reference);
-                              p^.location.reference.base:=hregister;
-                          end;
-                         { should be dereferenced later (FK)
-                         if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
-                           ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oo_is_class)<>0) then
-                           begin
-                              simple_loadn:=false;
-                              if hregister=R_NO then
-                                hregister:=getaddressreg;
-                              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
-                                hregister)));
-                              clear_reference(p^.location.reference);
-                              p^.location.reference.base:=hregister;
-                           end;
-                         }
-                      end;
-                 end;
-              procsym:
-                 begin
-                    {!!!!! Be aware, work on virtual methods too }
-                    stringdispose(p^.location.reference.symbol);
-                    p^.location.reference.symbol:=
-                      stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
-                 end;
-              typedconstsym :
-                 begin
-                    stringdispose(p^.location.reference.symbol);
-                    p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
-                 end;
-              else internalerror(4);
-         end;
-      end;
-
-
-{*****************************************************************************
-                             SecondAssignment
-*****************************************************************************}
-
-    procedure secondassignment(var p : ptree);
-
-      var
-         opsize : topsize;
-         withresult : boolean;
-         otlabel,hlabel,oflabel : pasmlabel;
-         hregister : tregister;
-         loc : tloc;
-         pushed : boolean;
-
-      begin
-         otlabel:=truelabel;
-         oflabel:=falselabel;
-         getlabel(truelabel);
-         getlabel(falselabel);
-         withresult:=false;
-         { calculate left sides }
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-         loc:=p^.left^.location.loc;
-         { lets try to optimize this (PM)             }
-         { define a dest_loc that is the location      }
-         { and a ptree to verify that it is the right }
-         { place to insert it                         }
-{$ifdef test_dest_loc}
-         if (aktexprlevel<4) then
-           begin
-              dest_loc_known:=true;
-              dest_loc:=p^.left^.location;
-              dest_loc_tree:=p^.right;
-           end;
-{$endif test_dest_loc}
-
-         pushed:=maybe_push(p^.right^.registers32,p^.left);
-         secondpass(p^.right);
-         if pushed then restore(p^.left);
-
-         if codegenerror then
-           exit;
-{$ifdef test_dest_loc}
-         dest_loc_known:=false;
-         if in_dest_loc then
-           begin
-              truelabel:=otlabel;
-              falselabel:=oflabel;
-              in_dest_loc:=false;
-              exit;
-           end;
-{$endif test_dest_loc}
-         if p^.left^.resulttype^.deftype=stringdef then
-           begin
-             { we do not need destination anymore }
-             del_reference(p^.left^.location.reference);
-             { only source if withresult is set }
-             if not(withresult) then
-               del_reference(p^.right^.location.reference);
-             loadstring(p);
-             ungetiftemp(p^.right^.location.reference);
-           end
-         else case p^.right^.location.loc of
-            LOC_REFERENCE,
-            LOC_MEM : begin
-                         { handle ordinal constants trimmed }
-                         if (p^.right^.treetype in [ordconstn,fixconstn]) or
-                            (loc=LOC_CREGISTER) then
-                           begin
-                              case p^.left^.resulttype^.size of
-                                 1 : opsize:=S_B;
-                                 2 : opsize:=S_W;
-                                 4 : opsize:=S_L;
-                              end;
-                              if loc=LOC_CREGISTER then
-                                exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,
-                                  newreference(p^.right^.location.reference),
-                                  p^.left^.location.register)))
-                              else
-                                exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,opsize,
-                                  p^.right^.location.reference.offset,
-                                  newreference(p^.left^.location.reference))));
-                              {exprasmlist^.concat(new(paicpu,op_const_loc(A_MOV,opsize,
-                                  p^.right^.location.reference.offset,
-                                  p^.left^.location)));}
-                           end
-                         else
-                           begin
-                              concatcopy(p^.right^.location.reference,
-                                p^.left^.location.reference,p^.left^.resulttype^.size,
-                                withresult);
-                              ungetiftemp(p^.right^.location.reference);
-                           end;
-                      end;
-            LOC_REGISTER,
-            LOC_CREGISTER : begin
-                              case p^.right^.resulttype^.size of
-                                 1 : opsize:=S_B;
-                                 2 : opsize:=S_W;
-                                 4 : opsize:=S_L;
-                              end;
-                              { simplified with op_reg_loc         }
-                              if loc=LOC_CREGISTER then
-                                exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,opsize,
-                                  p^.right^.location.register,
-                                  p^.left^.location.register)))
-                              else
-                                exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,opsize,
-                                  p^.right^.location.register,
-                                  newreference(p^.left^.location.reference))));
-                              {exprasmlist^.concat(new(paicpu,op_reg_loc(A_MOV,opsize,
-                                  p^.right^.location.register,
-                                  p^.left^.location)));             }
-
-                           end;
-            LOC_FPU : begin
-                              if loc<>LOC_REFERENCE then
-                                internalerror(10010)
-                              else
-                                floatstore(pfloatdef(p^.left^.resulttype)^.typ,
-                                  p^.right^.location,p^.left^.location.reference);
-                      end;
-            LOC_JUMP     : begin
-                              getlabel(hlabel);
-                              emitl(A_LABEL,truelabel);
-                              if loc=LOC_CREGISTER then
-                                exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,
-                                  1,p^.left^.location.register)))
-                              else
-                                exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,
-                                  1,newreference(p^.left^.location.reference))));
-                              {exprasmlist^.concat(new(paicpu,op_const_loc(A_MOV,S_B,
-                                  1,p^.left^.location)));}
-                              emitl(A_JMP,hlabel);
-                              emitl(A_LABEL,falselabel);
-                              if loc=LOC_CREGISTER then
-                                exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_B,
-                                  p^.left^.location.register)))
-                              else
-                                exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,
-                                  0,newreference(p^.left^.location.reference))));
-                              emitl(A_LABEL,hlabel);
-                           end;
-            LOC_FLAGS    : begin
-                              if loc=LOC_CREGISTER then
-                               begin
-                                exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
-                                  p^.left^.location.register)));
-                                exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_B,p^.left^.location.register)));
-                               end
-                              else
-                               begin
-                                 exprasmlist^.concat(new(paicpu,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
-                                    newreference(p^.left^.location.reference))));
-                                 exprasmlist^.concat(new(paicpu,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference))));
-                               end;
-
-                           end;
-         end;
-         truelabel:=otlabel;
-         falselabel:=oflabel;
-      end;
-
-
-{*****************************************************************************
-                             SecondFuncRetN
-*****************************************************************************}
-
-    procedure secondfuncret(var p : ptree);
-      var
-         hr : tregister;
-         hp : preference;
-         pp : pprocinfo;
-         hr_valid : boolean;
-      begin
-         clear_reference(p^.location.reference);
-         hr_valid:=false;
-{ !!!!!!! }
-
-         if @procinfo<>pprocinfo(p^.funcretprocinfo) then
-           begin
-              hr:=getaddressreg;
-              hr_valid:=true;
-              hp:=new_reference(procinfo^.framepointer,
-                procinfo^.framepointer_offset);
-              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hr)));
-
-              pp:=procinfo^.parent;
-              { walk up the stack frame }
-              while pp<>pprocinfo(p^.funcretprocinfo) do
-                begin
-                   hp:=new_reference(hr,
-                     pp^.framepointer_offset);
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hr)));
-                   pp:=pp^.parent;
-                end;
-              p^.location.reference.base:=hr;
-           end
-         else
-           p^.location.reference.base:=procinfo^.framepointer;
-         p^.location.reference.offset:=procinfo^.retoffset;
-         if ret_in_param(p^.retdef) then
-           begin
-              if not hr_valid then
-                { this was wrong !! PM }
-                hr:=getaddressreg;
-              exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hr)));
-              p^.location.reference.base:=hr;
-              p^.location.reference.offset:=0;
-           end;
-      end;
-
-{*****************************************************************************
-                           SecondArrayConstruct
-*****************************************************************************}
-
-      const
-        vtInteger    = 0;
-        vtBoolean    = 1;
-        vtChar       = 2;
-        vtExtended   = 3;
-        vtString     = 4;
-        vtPointer    = 5;
-        vtPChar      = 6;
-        vtObject     = 7;
-        vtClass      = 8;
-        vtWideChar   = 9;
-        vtPWideChar  = 10;
-        vtAnsiString = 11;
-        vtCurrency   = 12;
-        vtVariant    = 13;
-        vtInterface  = 14;
-        vtWideString = 15;
-        vtInt64      = 16;
-
-    procedure secondarrayconstruct(var p : ptree);
-      begin
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:37  michael
-  + removed logs
-
-}

compiler/old/cg68kmat.pas

@@ -1,458 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for math nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kmat;
-interface
-
-    uses
-      tree;
-
-    procedure secondmoddiv(var p : ptree);
-    procedure secondshlshr(var p : ptree);
-    procedure secondunaryminus(var p : ptree);
-    procedure secondnot(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k;
-
-{*****************************************************************************
-                             SecondModDiv
-*****************************************************************************}
-
-    { D0 and D1 used as temp (ok)   }
-    procedure secondmoddiv(var p : ptree);
-
-      var
-         hreg1 : tregister;
-         power : longint;
-         hl : pasmlabel;
-         reg: tregister;
-         pushed: boolean;
-         hl1: pasmlabel;
-      begin
-         secondpass(p^.left);
-         set_location(p^.location,p^.left^.location);
-         pushed:=maybe_push(p^.right^.registers32,p);
-         secondpass(p^.right);
-         if pushed then restore(p);
-
-         { put numerator in register }
-         if p^.left^.location.loc<>LOC_REGISTER then
-           begin
-              if p^.left^.location.loc=LOC_CREGISTER then
-                begin
-                  hreg1:=getregister32;
-                  emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1);
-                end
-              else
-                begin
-                  del_reference(p^.left^.location.reference);
-                  hreg1:=getregister32;
-                  exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
-                    hreg1)));
-                end;
-              clear_location(p^.left^.location);
-              p^.left^.location.loc:=LOC_REGISTER;
-              p^.left^.location.register:=hreg1;
-           end
-         else hreg1:=p^.left^.location.register;
-
-         if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
-            ispowerof2(p^.right^.value,power) then
-           begin
-              exprasmlist^.concat(new(paicpu, op_reg(A_TST, S_L, hreg1)));
-              getlabel(hl);
-              emitl(A_BPL,hl);
-              if (power = 1) then
-                 exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L,1, hreg1)))
-              else
-               Begin
-                 { optimize using ADDQ if possible!   }
-                 if (p^.right^.value-1) < 9 then
-                   exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1)))
-                 else
-                   exprasmlist^.concat(new(paicpu, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1)));
-               end;
-              emitl(A_LABEL, hl);
-              if (power > 0) and (power < 9) then
-                 exprasmlist^.concat(new(paicpu, op_const_reg(A_ASR, S_L,power, hreg1)))
-              else
-               begin
-                  exprasmlist^.concat(new(paicpu, op_const_reg(A_MOVE,S_L,power, R_D0)));
-                  exprasmlist^.concat(new(paicpu, op_reg_reg(A_ASR,S_L,R_D0, hreg1)));
-               end;
-           end
-         else
-           begin
-              { bring denominator to D1 }
-              { D1 is always free, it's }
-              { only used for temporary  }
-              { purposes                 }
-              if (p^.right^.location.loc<>LOC_REGISTER) and
-                 (p^.right^.location.loc<>LOC_CREGISTER) then
-                 begin
-                   del_reference(p^.right^.location.reference);
-                   p^.left^.location.loc:=LOC_REGISTER;
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1)));
-                end
-             else
-              begin
-                   ungetregister32(p^.right^.location.register);
-                   emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
-              end;
-
-              { on entering this section D1 should contain the divisor }
-
-              if (aktoptprocessor = MC68020) then
-              begin
-                 { Check if divisor is ZERO - if so call HALT_ERROR }
-                 { with d0 = 200 (Division by zero!)                }
-                 getlabel(hl1);
-                 exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,R_D1)));
-                 { if not zero then simply continue on }
-                 emitl(A_BNE,hl1);
-                 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,200,R_D0)));
-                 emitcall('FPC_HALT_ERROR',true);
-                 emitl(A_LABEL,hl1);
-                 if (p^.treetype = modn) then
-                 Begin
-                   reg := getregister32;
-                   exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,reg)));
-                   getlabel(hl);
-                   { here what we do is prepare the high register with the     }
-                   { correct sign. i.e we clear it, check if the low dword reg }
-                   { which will participate in the division is signed, if so we}
-                   { we extend the sign to the high doword register by inverting }
-                   { all the bits.                                             }
-                   exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,hreg1)));
-                   emitl(A_BPL,hl);
-                   exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,reg)));
-                   emitl(A_LABEL,hl);
-                   { reg:hreg1 / d1 }
-                   exprasmlist^.concat(new(paicpu,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1)));
-                   { hreg1 already contains quotient }
-                   { looking for remainder }
-                   exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,reg,hreg1)));
-                   ungetregister32(reg);
-                 end
-                 else
-                 { simple division... }
-                 Begin
-                   { reg:hreg1 / d1 }
-                   exprasmlist^.concat(new(paicpu,op_reg_reg(A_DIVS,S_L,R_D1,hreg1)));
-                 end;
-              end
-              else { MC68000 operations }
-                 begin
-                     { put numerator in d0 }
-                     emit_reg_reg(A_MOVE,S_L,hreg1,R_D0);
-                     { operation to perform on entry to both }
-                     { routines...  d0/d1                    }
-                     { return result in d0                   }
-                     if p^.treetype = divn then
-                       emitcall('FPC_LONGDIV',true)
-                     else
-                       emitcall('FPC_LONGMOD',true);
-                     emit_reg_reg(A_MOVE,S_L,R_D0,hreg1);
-              end; { endif }
-         end;
-         { this registers are always used when div/mod are present }
-         usedinproc:=usedinproc or ($800 shr word(R_D1));
-         usedinproc:=usedinproc or ($800 shr word(R_D0));
-         clear_location(p^.location);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=hreg1;
-      end;
-
-
-{*****************************************************************************
-                             SecondShlShr
-*****************************************************************************}
-
-    { D6 used as scratch (ok) }
-    procedure secondshlshr(var p : ptree);
-
-      var
-         hregister1,hregister2,hregister3 : tregister;
-         op : tasmop;
-         pushed : boolean;
-      begin
-
-         secondpass(p^.left);
-         pushed:=maybe_push(p^.right^.registers32,p);
-         secondpass(p^.right);
-         if pushed then restore(p);
-
-         { load left operators in a register }
-         if p^.left^.location.loc<>LOC_REGISTER then
-           begin
-              if p^.left^.location.loc=LOC_CREGISTER then
-                begin
-                   hregister1:=getregister32;
-                   emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
-                     hregister1);
-                end
-              else
-                begin
-                   del_reference(p^.left^.location.reference);
-                   hregister1:=getregister32;
-                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
-                     hregister1)));
-                end;
-           end
-         else hregister1:=p^.left^.location.register;
-
-         { determine operator }
-         if p^.treetype=shln then
-           op:=A_LSL
-         else
-           op:=A_LSR;
-
-         { shifting by a constant directly decode: }
-         if (p^.right^.treetype=ordconstn) then
-           begin
-             if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then
-                 exprasmlist^.concat(new(paicpu,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31,
-                   hregister1)))
-             else
-               begin
-                 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31,
-                   R_D6)));
-                 exprasmlist^.concat(new(paicpu,op_reg_reg(op,S_L,R_D6,hregister1)));
-               end;
-              p^.location.loc:=LOC_REGISTER;
-              p^.location.register:=hregister1;
-           end
-         else
-           begin
-              { load right operators in a register }
-              if p^.right^.location.loc<>LOC_REGISTER then
-                begin
-                   if p^.right^.location.loc=LOC_CREGISTER then
-                     begin
-                        hregister2:=getregister32;
-                        emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,
-                          hregister2);
-                     end
-                   else
-                     begin
-                        del_reference(p^.right^.location.reference);
-                        hregister2:=getregister32;
-                        exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
-                          hregister2)));
-                     end;
-                end
-              else hregister2:=p^.right^.location.register;
-
-
-              emit_reg_reg(op,S_L,hregister2,hregister1);
-              p^.location.register:=hregister1;
-           end;
-         { this register is always used when shl/shr are present }
-         usedinproc:=usedinproc or ($800 shr byte(R_D6));
-      end;
-
-{*****************************************************************************
-                             Secondunaryminus
-*****************************************************************************}
-
-    procedure secondunaryminus(var p : ptree);
-
-      begin
-         secondpass(p^.left);
-         p^.location.loc:=LOC_REGISTER;
-         case p^.left^.location.loc of
-            LOC_REGISTER : begin
-                              p^.location.register:=p^.left^.location.register;
-                              exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register)));
-                           end;
-            LOC_CREGISTER : begin
-                               p^.location.register:=getregister32;
-                               emit_reg_reg(A_MOVE,S_L,p^.location.register,
-                                 p^.location.register);
-                               exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register)));
-                            end;
-            LOC_REFERENCE,LOC_MEM :
-                           begin
-                              del_reference(p^.left^.location.reference);
-                              { change sign of a floating point  }
-                              { in the case of emulation, get    }
-                              { a free register, and change sign }
-                              { manually.                        }
-                              { otherwise simply load into an FPU}
-                              { register.                        }
-                              if (p^.left^.resulttype^.deftype=floatdef) and
-                                 (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
-                                begin
-                                   { move to FPU }
-                                   floatload(pfloatdef(p^.left^.resulttype)^.typ,
-                                     p^.left^.location.reference,p^.location);
-                                   if (cs_fp_emulation) in aktmoduleswitches then
-                                       { if in emulation mode change sign manually }
-                                       exprasmlist^.concat(new(paicpu,op_const_reg(A_BCHG,S_L,31,
-                                          p^.location.fpureg)))
-                                   else
-                                       exprasmlist^.concat(new(paicpu,op_reg(A_FNEG,S_FX,
-                                          p^.location.fpureg)));
-                                end
-                              else
-                                begin
-                                   p^.location.register:=getregister32;
-                                   exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                     newreference(p^.left^.location.reference),
-                                     p^.location.register)));
-                                   exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register)));
-                                end;
-                           end;
-            LOC_FPU : begin
-                              p^.location.loc:=LOC_FPU;
-                              p^.location.fpureg := p^.left^.location.fpureg;
-                              if (cs_fp_emulation) in aktmoduleswitches then
-                                  exprasmlist^.concat(new(paicpu,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg)))
-                              else
-                                 exprasmlist^.concat(new(paicpu,op_reg(A_FNEG,S_FX,p^.location.fpureg)));
-                           end;
-         end;
-{         emitoverflowcheck;}
-      end;
-
-
-{*****************************************************************************
-                               SecondNot
-*****************************************************************************}
-
-    procedure secondnot(var p : ptree);
-
-      const
-         flagsinvers : array[F_E..F_BE] of tresflags =
-            (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
-             F_A,F_AE,F_B,F_BE);
-
-      var
-         hl : pasmlabel;
-
-      begin
-         if (p^.resulttype^.deftype=orddef) and
-            (porddef(p^.resulttype)^.typ=bool8bit) then
-              begin
-                 case p^.location.loc of
-                    LOC_JUMP : begin
-                                  hl:=truelabel;
-                                  truelabel:=falselabel;
-                                  falselabel:=hl;
-                                  secondpass(p^.left);
-                                  maketojumpbool(p^.left);
-                                  hl:=truelabel;
-                                  truelabel:=falselabel;
-                                  falselabel:=hl;
-                               end;
-                    LOC_FLAGS : begin
-                                   secondpass(p^.left);
-                                   p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
-                                end;
-                    LOC_REGISTER : begin
-                                      secondpass(p^.left);
-                                      p^.location.register:=p^.left^.location.register;
-                                      exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register)));
-                                   end;
-                    LOC_CREGISTER : begin
-                                       secondpass(p^.left);
-                                       p^.location.loc:=LOC_REGISTER;
-                                       p^.location.register:=getregister32;
-                                       emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
-                                         p^.location.register);
-                                       exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register)));
-                                    end;
-                    LOC_REFERENCE,LOC_MEM : begin
-                                              secondpass(p^.left);
-                                              del_reference(p^.left^.location.reference);
-                                              p^.location.loc:=LOC_REGISTER;
-                                              p^.location.register:=getregister32;
-                                              if p^.left^.location.loc=LOC_CREGISTER then
-                                                emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
-                                                   p^.location.register)
-                                              else
-                                                exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,
-                                              newreference(p^.left^.location.reference),
-                                                p^.location.register)));
-                                              exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register)));
-                                           end;
-                 end;
-              end
-            else
-              begin
-                secondpass(p^.left);
-                p^.location.loc:=LOC_REGISTER;
-
-                case p^.left^.location.loc of
-                   LOC_REGISTER : begin
-                                     p^.location.register:=p^.left^.location.register;
-                                     exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));
-                                  end;
-                   LOC_CREGISTER : begin
-                                     p^.location.register:=getregister32;
-                                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
-                                       p^.location.register);
-                                     exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));
-                                   end;
-                   LOC_REFERENCE,LOC_MEM :
-                                  begin
-                                     del_reference(p^.left^.location.reference);
-                                     p^.location.register:=getregister32;
-                                     exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                                       newreference(p^.left^.location.reference),
-                                       p^.location.register)));
-                                     exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));
-                                  end;
-                end;
-                {if  p^.left^.location.loc=loc_register then
-                  p^.location.register:=p^.left^.location.register
-                else
-                  begin
-                     del_locref(p^.left^.location);
-                     p^.location.register:=getregister32;
-                     exprasmlist^.concat(new(paicpu,op_loc_reg(A_MOV,S_L,
-                       p^.left^.location,
-                       p^.location.register)));
-                  end;
-                exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));}
-
-             end;
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:37  michael
-  + removed logs
-
-}

compiler/old/cg68kmem.pas

@@ -1,734 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for in memory related nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kmem;
-interface
-
-    uses
-      tree;
-
-    procedure secondloadvmt(var p : ptree);
-    procedure secondhnewn(var p : ptree);
-    procedure secondnewn(var p : ptree);
-    procedure secondhdisposen(var p : ptree);
-    procedure secondsimplenewdispose(var p : ptree);
-    procedure secondaddr(var p : ptree);
-    procedure seconddoubleaddr(var p : ptree);
-    procedure secondderef(var p : ptree);
-    procedure secondsubscriptn(var p : ptree);
-    procedure secondvecn(var p : ptree);
-    procedure secondselfn(var p : ptree);
-    procedure secondwith(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k;
-
-
-{*****************************************************************************
-                             SecondLoadVMT
-*****************************************************************************}
-
-    procedure secondloadvmt(var p : ptree);
-      begin
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=getregister32;
-         exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE,
-            S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
-            p^.location.register)));
-      end;
-
-
-{*****************************************************************************
-                             SecondHNewN
-*****************************************************************************}
-
-    procedure secondhnewn(var p : ptree);
-      begin
-      end;
-
-
-{*****************************************************************************
-                             SecondNewN
-*****************************************************************************}
-
-    procedure secondnewn(var p : ptree);
-      var
-         pushed : tpushed;
-         r : preference;
-      begin
-         if assigned(p^.left) then
-           begin
-              secondpass(p^.left);
-              p^.location.register:=p^.left^.location.register;
-           end
-         else
-           begin
-              pushusedregisters(pushed,$ff);
-
-              { code copied from simplenewdispose PM }
-              { determines the size of the mem block }
-              push_int(ppointerdef(p^.resulttype)^.definition^.size);
-
-              gettempofsizereference(target_os.size_of_pointer,p^.location.reference);
-              emitpushreferenceaddr(exprasmlist,p^.location.reference);
-
-              emitcall('FPC_GETMEM',true);
-{!!!!!!!}
-(*              if ppointerdef(p^.resulttype)^.definition^.needs_inittable then
-                begin
-                   new(r);
-                   reset_reference(r^);
-                   r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label));
-                   emitpushreferenceaddr(exprasmlist,r^);
-                   { push pointer adress }
-                   emitpushreferenceaddr(exprasmlist,p^.location.reference);
-                   stringdispose(r^.symbol);
-                   dispose(r);
-                   emitcall('FPC_INITIALIZE',true);
-                end; *)
-              popusedregisters(pushed);
-              { may be load ESI }
-              maybe_loada5;
-           end;
-         if codegenerror then
-           exit;
-      end;
-
-
-{*****************************************************************************
-                             SecondDisposeN
-*****************************************************************************}
-
-    procedure secondhdisposen(var p : ptree);
-      begin
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-         clear_reference(p^.location.reference);
-         case p^.left^.location.loc of
-            LOC_REGISTER,
-            LOC_CREGISTER : begin
-                               p^.location.reference.base:=getaddressreg;
-                               exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-                                 p^.left^.location.register,
-                                 p^.location.reference.base)));
-                            end;
-            LOC_MEM,LOC_REFERENCE :
-                            begin
-                               del_reference(p^.left^.location.reference);
-                               p^.location.reference.base:=getaddressreg;
-                               exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
-                                 p^.location.reference.base)));
-                            end;
-         end;
-      end;
-
-
-{*****************************************************************************
-                             SecondNewDispose
-*****************************************************************************}
-
-    procedure secondsimplenewdispose(var p : ptree);
-
-
-      var
-         pushed : tpushed;
-         r : preference;
-
-      begin
-         secondpass(p^.left);
-         if codegenerror then
-           exit;
-
-         pushusedregisters(pushed,$ffff);
-         { determines the size of the mem block }
-         push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
-
-         { push pointer adress }
-         case p^.left^.location.loc of
-            LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-              p^.left^.location.register,R_SPPUSH)));
-            LOC_REFERENCE:
-              emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-
-         end;
-
-         { call the mem handling procedures }
-         case p^.treetype of
-           simpledisposen:
-             begin
-                if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
-                  begin
-{!!!!!!!}
-
-(*                     new(r);
-                     reset_reference(r^);
-                     r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label));
-                     emitpushreferenceaddr(exprasmlist,r^);
-                     { push pointer adress }
-                     case p^.left^.location.loc of
-                        LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,
-                          p^.left^.location.register)));
-                        LOC_REFERENCE:
-                          emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                     end;
-                     emitcall('FPC_FINALIZE',true); *)
-                  end;
-                emitcall('FPC_FREEMEM',true);
-             end;
-           simplenewn:
-             begin
-                emitcall('FPC_GETMEM',true);
-                if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
-                  begin
-{!!!!!!!}
-
-(*                     new(r);
-                     reset_reference(r^);
-                     r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label));
-                     emitpushreferenceaddr(exprasmlist,r^);
-                     { push pointer adress }
-                     case p^.left^.location.loc of
-                        LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,
-                          p^.left^.location.register)));
-                        LOC_REFERENCE:
-                          emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
-                     end;
-                     emitcall('FPC_INITIALIZE',true); *)
-                  end;
-             end;
-         end;
-         popusedregisters(pushed);
-         { may be load ESI }
-         maybe_loada5;
-      end;
-
-
-{*****************************************************************************
-                             SecondAddr
-*****************************************************************************}
-
-    procedure secondaddr(var p : ptree);
-      begin
-         secondpass(p^.left);
-         p^.location.loc:=LOC_REGISTER;
-         p^.location.register:=getregister32;
-         {@ on a procvar means returning an address to the procedure that
-          is stored in it.}
-       { yes but p^.left^.symtableentry can be nil
-       for example on @self !! }
-         { symtableentry can be also invalid, if left is no tree node }
-         if (p^.left^.treetype=loadn) and
-          assigned(p^.left^.symtableentry) and
-            (p^.left^.symtableentry^.typ=varsym) and
-          (Pvarsym(p^.left^.symtableentry)^.definition^.deftype=
-           procvardef) then
-            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-             newreference(p^.left^.location.reference),
-             p^.location.register)))
-         else
-           begin
-            exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-             newreference(p^.left^.location.reference),R_A0)));
-            exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-             R_A0,p^.location.register)));
-           end;
-         { for use of other segments }
-         { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
-             p^.location.segment:=p^.left^.location.reference.segment;
-         }
-         del_reference(p^.left^.location.reference);
-      end;
-
-
-{*****************************************************************************
-                             SecondDoubleAddr
-*****************************************************************************}
-
-    procedure seconddoubleaddr(var p : ptree);
-      begin
-         secondpass(p^.left);
-         p^.location.loc:=LOC_REGISTER;
-         del_reference(p^.left^.location.reference);
-         p^.location.register:=getregister32;
-         exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-          newreference(p^.left^.location.reference),R_A0)));
-         exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,
-          R_A0,p^.location.register)));
-      end;
-
-
-{*****************************************************************************
-                             SecondDeRef
-*****************************************************************************}
-
-    procedure secondderef(var p : ptree);
-      var
-         hr : tregister;
-
-      begin
-         secondpass(p^.left);
-         clear_reference(p^.location.reference);
-         case p^.left^.location.loc of
-            LOC_REGISTER : Begin
-                             hr := getaddressreg;
-                             emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
-                             p^.location.reference.base:=hr;
-                             ungetregister(p^.left^.location.register);
-                           end;
-            LOC_CREGISTER : begin
-                               { ... and reserve one for the pointer }
-                               hr:=getaddressreg;
-                               emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
-                                      p^.location.reference.base:=hr;
-                               { LOC_REGISTER indicates that this is a
-                               variable register which should not be freed. }
-{                               ungetregister(p^.left^.location.register); }
-                            end;
-            else
-              begin
-                 { free register }
-                 del_reference(p^.left^.location.reference);
-
-                 { ...and reserve one for the pointer }
-                 hr:=getaddressreg;
-                 exprasmlist^.concat(new(paicpu,op_ref_reg(
-                   A_MOVE,S_L,newreference(p^.left^.location.reference),
-                   hr)));
-                 p^.location.reference.base:=hr;
-              end;
-         end;
-      end;
-
-
-{*****************************************************************************
-                             SecondSubScriptN
-*****************************************************************************}
-
-    procedure secondsubscriptn(var p : ptree);
-      var
-       hr: tregister;
-
-      begin
-
-         secondpass(p^.left);
-
-         if codegenerror then
-           exit;
-         { classes must be dereferenced implicit }
-         if (p^.left^.resulttype^.deftype=objectdef) and
-           pobjectdef(p^.left^.resulttype)^.is_class then
-           begin
-             clear_reference(p^.location.reference);
-             case p^.left^.location.loc of
-                LOC_REGISTER:
-                  begin
-                     { move it to an address register...}
-                     hr:=getaddressreg;
-                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
-                     p^.location.reference.base:=hr;
-                     { free register }
-                     ungetregister(p^.left^.location.register);
-                  end;
-                LOC_CREGISTER:
-                  begin
-                     { ... and reserve one for the pointer }
-                     hr:=getaddressreg;
-                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
-                       p^.location.reference.base:=hr;
-                  end;
-                else
-                  begin
-                     { free register }
-                     del_reference(p^.left^.location.reference);
-
-                     { ... and reserve one for the pointer }
-                     hr:=getaddressreg;
-                     exprasmlist^.concat(new(paicpu,op_ref_reg(
-                       A_MOVE,S_L,newreference(p^.left^.location.reference),
-                       hr)));
-                     p^.location.reference.base:=hr;
-                  end;
-             end;
-           end
-         else
-           set_location(p^.location,p^.left^.location);
-
-         inc(p^.location.reference.offset,p^.vs^.address);
-      end;
-
-
-{*****************************************************************************
-                               SecondVecN
-*****************************************************************************}
-
-    { used D0, D1 as scratch (ok) }
-    { arrays ...                  }
-    { Sets up the array and string }
-    { references .                 }
-    procedure secondvecn(var p : ptree);
-
-      var
-         pushed : boolean;
-         ind : tregister;
-         _p : ptree;
-
-      procedure calc_emit_mul;
-
-        var
-           l1,l2 : longint;
-
-        begin
-           l1:=p^.resulttype^.size;
-           case l1 of
-              1     : p^.location.reference.scalefactor:=l1;
-              2 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,ind)));
-              4 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,ind)));
-              8 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,3,ind)));
-           else
-             begin
-               if ispowerof2(l1,l2) then
-                 exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,l2,ind)))
-                   else
-                 begin
-                   { use normal MC68000 signed multiply }
-                   if (l1 >= -32768) and (l1 <= 32767) then
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_W,l1,ind)))
-                   else
-                   { use long MC68020 long multiply }
-                   if (aktoptprocessor = MC68020) then
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_L,l1,ind)))
-                   else
-                   { MC68000 long multiply }
-                     begin
-                       exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,l1,R_D0)));
-                       exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,ind,R_D1)));
-                       emitcall('FPC_LONGMUL',true);
-                       exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,ind)));
-                     end;
-                 end;
-             end; { else case }
-            end; { end case }
-        end; { calc_emit_mul }
-
-      var
-       extraoffset : longint;
-         t : ptree;
-         hp : preference;
-         tai:paicpu;
-       reg: tregister;
-
-      begin
-         secondpass(p^.left);
-         { RESULT IS IN p^.location.reference }
-         set_location(p^.location,p^.left^.location);
-
-         { offset can only differ from 0 if arraydef }
-         if p^.left^.resulttype^.deftype=arraydef then
-           dec(p^.location.reference.offset,
-             p^.resulttype^.size*
-             parraydef(p^.left^.resulttype)^.lowrange);
-
-         if p^.right^.treetype=ordconstn then
-           begin
-              { offset can only differ from 0 if arraydef }
-              if (p^.left^.resulttype^.deftype=arraydef) then
-                begin
-                   if not(is_open_array(p^.left^.resulttype)) then
-                     begin
-                        if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
-                           (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
-                          CGMessage(parser_e_range_check_error);
-
-                        dec(p^.left^.location.reference.offset,
-                          p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
-                     end
-                   else
-                     begin
-                        { range checking for open arrays }
-                     end;
-                end;
-              inc(p^.left^.location.reference.offset,
-                p^.right^.value*p^.resulttype^.size);
-              p^.left^.resulttype:=p^.resulttype;
-              disposetree(p^.right);
-              _p:=p^.left;
-              putnode(p);
-              p:=_p;
-           end
-         else
-           begin
-              { quick hack, to overcome Delphi 2 }
-              if (cs_regalloc in aktglobalswitches) and
-                (p^.left^.resulttype^.deftype=arraydef) then
-                begin
-                   extraoffset:=0;
-                   if (p^.right^.treetype=addn) then
-                     begin
-                        if p^.right^.right^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.right^.value;
-                             t:=p^.right^.left;
-                             putnode(p^.right);
-                             putnode(p^.right^.right);
-                             p^.right:=t
-                          end
-                        else if p^.right^.left^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.left^.value;
-                             t:=p^.right^.right;
-                                    putnode(p^.right);
-                             putnode(p^.right^.left);
-                             p^.right:=t
-                          end;
-                     end
-                   else if (p^.right^.treetype=subn) then
-                     begin
-                        if p^.right^.right^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.right^.value;
-                             t:=p^.right^.left;
-                             putnode(p^.right);
-                             putnode(p^.right^.right);
-                             p^.right:=t
-                          end
-                        else if p^.right^.left^.treetype=ordconstn then
-                          begin
-                             extraoffset:=p^.right^.left^.value;
-                                    t:=p^.right^.right;
-                             putnode(p^.right);
-                             putnode(p^.right^.left);
-                             p^.right:=t
-                          end;
-                     end;
-                   inc(p^.location.reference.offset,
-                     p^.resulttype^.size*extraoffset);
-                end;
-              { calculate from left to right }
-              if (p^.location.loc<>LOC_REFERENCE) and
-                 (p^.location.loc<>LOC_MEM) then
-                CGMessage(cg_e_illegal_expression);
-
-              pushed:=maybe_push(p^.right^.registers32,p);
-              secondpass(p^.right);
-              if pushed then restore(p);
-                 case p^.right^.location.loc of
-                LOC_REGISTER : begin
-                                 ind:=p^.right^.location.register;
-                                 case p^.right^.resulttype^.size of
-                                 1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                                      $ff,ind)));
-                                 2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                                      $ffff,ind)));
-                                 end;
-                               end;
-
-                LOC_CREGISTER : begin
-                                   ind:=getregister32;
-                                   emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind);
-                                   case p^.right^.resulttype^.size of
-                                   1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                                      $ff,ind)));
-                                   2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                                      $ffff,ind)));
-                                   end;
-                                end;
-                   LOC_FLAGS:
-                     begin
-                        ind:=getregister32;
-                        exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind)));
-                        exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,ind)));
-                     end
-                else { else outer case }
-                   begin
-                      del_reference(p^.right^.location.reference);
-                           ind:=getregister32;
-
-                      exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                        newreference(p^.right^.location.reference),ind)));
-
-                           {Booleans are stored in an 8 bit memory location, so
-                           the use of MOVL is not correct.}
-                      case p^.right^.resulttype^.size of
-                        1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                          $ff,ind)));
-                        2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                          $ffff,ind)));
-                      end; { end case }
-                end; { end else begin }
-           end;
-
-         { produce possible range check code: }
-         if cs_check_range in aktlocalswitches  then
-           begin
-              if p^.left^.resulttype^.deftype=arraydef then
-                begin
-                   new(hp);
-                   reset_reference(hp^);
-                   parraydef(p^.left^.resulttype)^.genrangecheck;
-                   hp^.symbol:=stringdup(parraydef(p^.left^.resulttype)^.getrangecheckstring);
-                   emit_bounds_check(hp^,ind);
-                end;
-           end;
-
-         { ------------------------ HANDLE INDEXING ----------------------- }
-         { In Motorola 680x0 mode, displacement can only be of 64K max.     }
-         { Therefore instead of doing a direct displacement, we must first  }
-         { load the new address into an address register. Therefore the     }
-         { symbol is not used.                                              }
-         if assigned(p^.location.reference.symbol) then
-           begin
-              if p^.location.reference.base <> R_NO then
-                CGMessage(cg_f_secondvecn_base_defined_twice);
-              p^.location.reference.base:=getaddressreg;
-              exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0),
-                p^.location.reference.base)));
-              stringdispose(p^.location.reference.symbol);
-           end;
-
-         if (p^.location.reference.index=R_NO) then
-           begin
-              p^.location.reference.index:=ind;
-              calc_emit_mul;
-              { here we must check for the offset      }
-              { and if out of bounds for the motorola  }
-              { eg: out of signed d8 then reload index }
-              { with correct value.                    }
-              if p^.location.reference.offset > 127 then
-                begin
-                   exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind)));
-                   p^.location.reference.offset := 0;
-                end
-              else if p^.location.reference.offset < -128 then
-                begin
-                   exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind)));
-                   p^.location.reference.offset := 0;
-                end;
-           end
-         { if no index then allways get an address register !! PM }
-         else if p^.location.reference.base=R_NO then
-           begin
-              case p^.location.reference.scalefactor of
-                  2 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,p^.location.reference.index)));
-                  4 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,p^.location.reference.index)));
-                  8 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,3,p^.location.reference.index)));
-                end;
-              calc_emit_mul;
-
-              { we must use address register to put index in base }
-              { compare with cgi386.pas                           }
-
-              reg := getaddressreg;
-              p^.location.reference.base := reg;
-
-              emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg);
-              ungetregister(p^.location.reference.index);
-
-              p^.location.reference.index:=ind;
-           end
-         else
-           begin
-              reg := getaddressreg;
-              exprasmlist^.concat(new(paicpu,op_ref_reg(
-                A_LEA,S_L,newreference(p^.location.reference),
-                reg)));
-
-              ungetregister(p^.location.reference.base);
-              { the symbol offset is loaded,               }
-              { so release the symbol name and set symbol  }
-              { to nil                                     }
-              stringdispose(p^.location.reference.symbol);
-              p^.location.reference.offset:=0;
-              calc_emit_mul;
-              p^.location.reference.base:=reg;
-              ungetregister32(p^.location.reference.index);
-              p^.location.reference.index:=ind;
-         end;
-         end;
-      end;
-
-
-{*****************************************************************************
-                               SecondSelfN
-*****************************************************************************}
-
-    procedure secondselfn(var p : ptree);
-      begin
-         clear_reference(p^.location.reference);
-         p^.location.reference.base:=R_A5;
-      end;
-
-
-{*****************************************************************************
-                               SecondWithN
-*****************************************************************************}
-
-    procedure secondwith(var p : ptree);
-       var
-          ref : treference;
-          symtable : psymtable;
-          i : longint;
-
-       begin
-          if assigned(p^.left) then
-            begin
-               secondpass(p^.left);
-               ref.symbol:=nil;
-               gettempofsizereference(4,ref);
-               exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-                 newreference(p^.left^.location.reference),R_A0)));
-               exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,
-                 R_A0,newreference(ref))));
-               del_reference(p^.left^.location.reference);
-               { the offset relative to (%ebp) is only needed here! }
-               symtable:=p^.withsymtable;
-               for i:=1 to p^.tablecount do
-                 begin
-                    symtable^.datasize:=ref.offset;
-                    symtable:=symtable^.next;
-                 end;
-
-               { p^.right can be optimize out !!! }
-               if p^.right<>nil then
-                 secondpass(p^.right);
-               { clear some stuff }
-               ungetiftemp(ref);
-            end;
-       end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:37  michael
-  + removed logs
-
-}

compiler/old/cg68kset.pas

@@ -1,822 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Generate m68k assembler for in set/case nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit cg68kset;
-interface
-
-    uses
-      tree;
-
-    procedure secondsetelement(var p : ptree);
-    procedure secondin(var p : ptree);
-    procedure secondcase(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,symconst,
-      cobjects,verbose,globals,
-      symtable,aasm,types,
-      hcodegen,temp_gen,pass_2,
-      cpubase,cga68k,tgen68k;
-
-    const
-      bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
-
-{*****************************************************************************
-                              SecondSetElement
-*****************************************************************************}
-
-    procedure secondsetelement(var p : ptree);
-       begin
-       { load first value in 32bit register }
-         secondpass(p^.left);
-         if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-           emit_to_reg32(p^.left^.location.register);
-
-       { also a second value ? }
-         if assigned(p^.right) then
-           begin
-             secondpass(p^.right);
-             if p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-              emit_to_reg32(p^.right^.location.register);
-           end;
-
-         { we doesn't modify the left side, we check only the type }
-         set_location(p^.location,p^.left^.location);
-       end;
-
-
-{*****************************************************************************
-                              SecondIn
-*****************************************************************************}
-
-    { could be built into secondadd but it }
-    { should be easy to read }
-    procedure secondin(var p : ptree);
-
-
-      type  Tsetpart=record
-                range:boolean;      {Part is a range.}
-                start,stop:byte;    {Start/stop when range; Stop=element
-                                     when an element.}
-            end;
-
-      var
-         pushed,ranges : boolean;
-         hr : tregister;
-         setparts:array[1..8] of Tsetpart;
-         i,numparts:byte;
-         {href,href2:Treference;}
-         l,l2 : pasmlabel;
-         hl,hl1 : pasmlabel;
-         hl2, hl3: pasmlabel;
-         opsize : topsize;
-
-
-               function swaplongint(l : longint): longint;
-               var
-                 w1: word;
-                 w2: word;
-               begin
-                 w1:=l and $ffff;
-                 w2:=l shr 16;
-                 l:=swap(w2)+(longint(swap(w1)) shl 16);
-                 swaplongint:=l;
-               end;
-
-            function analizeset(Aset:Pconstset):boolean;
-
-            type    byteset=set of byte;
-                    tlongset  = array[0..7] of longint;
-            var compares,maxcompares:word;
-                someset : tlongset;
-                i:byte;
-
-            begin
-                analizeset:=false;
-                ranges:=false;
-                numparts:=0;
-                compares:=0;
-                {Lots of comparisions take a lot of time, so do not allow
-                 too much comparisions. 8 comparisions are, however, still
-                 smalller than emitting the set.}
-                maxcompares:=5;
-                if cs_littlesize in aktglobalswitches then
-                    maxcompares:=8;
-                move(ASet^,someset,32);
-                { On Big endian machines sets are stored   }
-                { as INTEL Little-endian format, therefore }
-                { we must convert it to the correct format }
-{$IFDEF BIG_ENDIAN}
-                for I:=0 to 7 do
-                  someset[i]:=swaplongint(someset[i]);
-{$ENDIF}
-                for i:=0 to 255 do
-                    if i in byteset(someset) then
-                        begin
-                            if (numparts=0) or
-                             (i<>setparts[numparts].stop+1) then
-                                begin
-                                    {Set element is a separate element.}
-                                    inc(compares);
-                                    if compares>maxcompares then
-                                        exit;
-                                    inc(numparts);
-                                    setparts[numparts].range:=false;
-                                    setparts[numparts].stop:=i;
-                                end
-                             else
-                                {Set element is part of a range.}
-                                if not setparts[numparts].range then
-                                    begin
-                                        {Transform an element into a range.}
-                                        setparts[numparts].range:=true;
-                                        setparts[numparts].start:=
-                                         setparts[numparts].stop;
-                                        setparts[numparts].stop:=i;
-                                        inc(compares);
-                                        if compares>maxcompares then
-                                            exit;
-                                    end
-                                else
-                                    begin
-                                        {Extend a range.}
-                                        setparts[numparts].stop:=i;
-                                        {A range of two elements can better
-                                         be checked as two separate ones.
-                                         When extending a range, our range
-                                         becomes larger than two elements.}
-                                        ranges:=true;
-                                    end;
-                        end;
-                analizeset:=true;
-            end;  { end analizeset }
-
-      begin
-         if psetdef(p^.right^.resulttype)^.settype=smallset then
-           begin
-              if p^.left^.treetype=ordconstn then
-                begin
-                   { only compulsory }
-                   secondpass(p^.left);
-                   secondpass(p^.right);
-                   if codegenerror then
-                     exit;
-                   p^.location.resflags:=F_NE;
-                   { Because of the Endian of the m68k, we have to consider this as a  }
-                   { normal set and load it byte per byte, otherwise we will never get }
-                   { the correct result.                                               }
-                   case p^.right^.location.loc of
-                     LOC_REGISTER,LOC_CREGISTER :
-                       begin
-                         emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
-                         exprasmlist^.concat(new(paicpu,
-                           op_const_reg(A_AND,S_L, 1 shl (p^.left^.value and 31),R_D1)));
-                       end;
-                   else
-                       begin
-                         exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(
-                           p^.right^.location.reference),R_D1)));
-                         exprasmlist^.concat(new(paicpu,op_const_reg(
-                           A_AND,S_L,1 shl (p^.left^.value and 31) ,R_D1)));
-                       end;
-                   end;
-                   del_reference(p^.right^.location.reference);
-                end
-              else
-                begin
-                   { calculate both operators }
-                   { the complex one first }
-                   firstcomplex(p);
-                   secondpass(p^.left);
-                   { are too few registers free? }
-                   pushed:=maybe_push(p^.right^.registers32,p^.left);
-                   secondpass(p^.right);
-                   if pushed then
-                     restore(p^.left);
-                   { of course not commutative }
-                   if p^.swaped then
-                        swaptree(p);
-                   { load index into register }
-                   case p^.left^.location.loc of
-                      LOC_REGISTER,
-                      LOC_CREGISTER :
-                          hr:=p^.left^.location.register;
-                      else
-                         begin
-                            { Small sets are always 32 bit values, there is no  }
-                            { way they can be anything else, so no problems here}
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
-                              newreference(p^.left^.location.reference),R_D1)));
-                            hr:=R_D1;
-                            del_reference(p^.left^.location.reference);
-                         end;
-                   end;
-                   case p^.right^.location.loc of
-                      LOC_REGISTER,
-                      LOC_CREGISTER : exprasmlist^.concat(new(paicpu, op_reg_reg(A_BTST,S_L,hr,p^.right^.location.register)));
-                      else
-                         begin
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
-                              R_D0)));
-                            exprasmlist^.concat(new(paicpu,op_reg_reg(A_BTST,S_L,hr,R_D0)));
-                            del_reference(p^.right^.location.reference);
-                         end;
-                   end;
-                   { support carry routines }
-                   { sets the carry flags according to the result of BTST }
-                   { i.e the Z flag.                                      }
-                   getlabel(hl);
-                   emitl(A_BNE,hl);
-                   { leave all bits unchanged except Carry  = 0 }
-                   exprasmlist^.concat(new(paicpu, op_const_reg(A_AND, S_B, $FE, R_CCR)));
-                   getlabel(hl1);
-                   emitl(A_BRA,hl1);
-                   emitl(A_LABEL, hl);
-                   { set carry to 1 }
-                   exprasmlist^.concat(new(paicpu, op_const_reg(A_OR, S_B, $01, R_CCR)));
-                   emitl(A_LABEL, hl1);
-                   { end support carry routines }
-                   p^.location.loc:=LOC_FLAGS;
-                   p^.location.resflags:=F_C;
-                end;
-           end
-         else { //// NOT a small set  //// }
-           begin
-              if p^.left^.treetype=ordconstn then
-                begin
-                   { only compulsory }
-                   secondpass(p^.left);
-                   secondpass(p^.right);
-                   if codegenerror then
-                     exit;
-                   p^.location.resflags:=F_NE;
-                   inc(p^.right^.location.reference.offset,(p^.left^.value div 32)*4);
-                   exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE, S_L,
-                       newreference(p^.right^.location.reference), R_D1)));
-                   exprasmlist^.concat(new(paicpu, op_const_reg(A_AND, S_L,
-                       1 shl (p^.left^.value mod 32),R_D1)));
-                   del_reference(p^.right^.location.reference);
-                end
-             else
-                begin
-                  if (p^.right^.treetype=setconstn) and
-                     analizeset(p^.right^.value_set) then
-                    begin
-                      {It gives us advantage to check for the set elements
-                        separately instead of using the SET_IN_BYTE procedure.
-                       To do: Build in support for LOC_JUMP.}
-                      secondpass(p^.left);
-                      {We won't do a second pass on p^.right, because
-                      this will emit the constant set.}
-                      case p^.left^.location.loc of
-                        LOC_REGISTER,
-                        LOC_CREGISTER :
-                           exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                             255,p^.left^.location.register)));
-                        else
-                         Begin
-                           { Because of the m68k endian, then we must LOAD normally the    }
-                           { value into a register first, all depending on the source      }
-                           { size!                                                         }
-                           opsize:=S_NO;
-                           case integer(p^.left^.resulttype^.size) of
-                             1 : opsize:=S_B;
-                             2 : opsize:=S_W;
-                             4 : opsize:=S_L;
-                           else
-                             internalerror(19);
-                           end;
-                           exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,
-                             newreference(p^.left^.location.reference),R_D0)));
-                           exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,
-                             255,R_D0)));
-                         end;
-                      end;
-                      {Get a label to jump to the end.}
-                      p^.location.loc:=LOC_FLAGS;
-                      {It's better to use the zero flag when there are no ranges.}
-                      if ranges then
-                        p^.location.resflags:=F_C
-                      else
-                        p^.location.resflags:=F_E;
-                      {href.symbol := nil;
-                      clear_reference(href);}
-                      getlabel(l);
-                      {href.symbol:=stringdup(lab2str(l));}
-                      for i:=1 to numparts do
-                          if setparts[i].range then
-                             begin
-                                  {Check if left is in a range.}
-                                  {Get a label to jump over the check.}
-                                  {href2.symbol := nil;
-                                  clear_reference(href2);}
-                                  getlabel(l2);
-                                  {href.symbol:=stringdup(lab2str(l2));}
-                                  if setparts[i].start=setparts[i].stop-1 then
-                                  begin
-                                    case p^.left^.location.loc of
-                                      LOC_REGISTER,
-                                      LOC_CREGISTER :
-                                         exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                           setparts[i].start,p^.left^.location.register)));
-                                    else
-                                         exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                           setparts[i].start,R_D0)));
-{                                         exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B,
-                                           setparts[i].start,newreference(p^.left^.location.reference))));}
-                                    end;
-                                  {Result should be in carry flag when ranges are used.}
-                                  { Here the m68k does not affect any flag except the  }
-                                  { flag which is OR'ed                                }
-                                  if ranges then
-                                     exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR)));
-                                  {If found, jump to end.}
-                                  emitl(A_BEQ,l);
-                                  case p^.left^.location.loc of
-                                    LOC_REGISTER,
-                                    LOC_CREGISTER :
-                                      exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                        setparts[i].stop,p^.left^.location.register)));
-                                    else
-                                      exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                        setparts[i].stop,R_D0)));
-{                                      exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B,
-                                      setparts[i].stop,newreference(p^.left^.location.reference))));}
-                                  end;
-                                  {Result should be in carry flag when ranges are used.}
-                                  { Here the m68k does not affect any flag except the  }
-                                  { flag which is OR'ed                                }
-                                  if ranges then
-                                     exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR)));
-                                  {If found, jump to end.}
-                                  emitl(A_BEQ,l);
-                             end
-                          else
-                             begin
-                               if setparts[i].start<>0 then
-                                  begin
-                                  {We only check for the lower bound if it is > 0, because
-                                   set elements lower than 0 do nt exist.}
-                                    case p^.left^.location.loc of
-                                      LOC_REGISTER,
-                                      LOC_CREGISTER :
-                                        exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                        setparts[i].start,p^.left^.location.register)));
-                                    else
-                                        exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                        setparts[i].start,R_D0)));
-{                                        exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B,
-                                        setparts[i].start,newreference(p^.left^.location.reference)))); }
-                                    end;
-                                    {If lower, jump to next check.}
-                                    emitl(A_BCS,l2);
-                                    end;
-                                    if setparts[i].stop<>255 then
-                                       begin
-                                       {We only check for the high bound if it is < 255, because
-                                          set elements higher than 255 do nt exist.}
-                                          case p^.left^.location.loc of
-                                            LOC_REGISTER,
-                                            LOC_CREGISTER :
-                                              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                                setparts[i].stop+1,p^.left^.location.register)));
-                                          else
-                                              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                                setparts[i].stop+1,R_D0)));
-{                                              exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B,
-                                                setparts[i].stop+1,newreference(p^.left^.location.reference))));}
-                                          end; { end case }
-                                          {If higher, element is in set.}
-                                          emitl(A_BCS,l);
-                                       end
-                                     else
-                                       begin
-                                         exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR)));
-                                         emitl(A_JMP,l);
-                                       end;
-                                  end;
-                               {Emit the jump over label.}
-                               exprasmlist^.concat(new(pai_label,init(l2)));
-                             end
-                            else
-                               begin
-                               {Emit code to check if left is an element.}
-                                 case p^.left^.location.loc of
-                                   LOC_REGISTER,
-                                   LOC_CREGISTER :
-                                     exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                      setparts[i].stop,p^.left^.location.register)));
-                                   else
-{                                     exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B,
-                                     setparts[i].stop,newreference(p^.left^.location.reference))));}
-                                     exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W,
-                                      setparts[i].stop,R_D0)));
-                                   end;
-                                 {Result should be in carry flag when ranges are used.}
-                                 if ranges then
-                                   exprasmlist^.concat(new(paicpu, op_const_reg(A_OR,S_B,$01,R_CCR)));
-                                   {If found, jump to end.}
-                                 emitl(A_BEQ,l);
-                               end;
-                            if ranges then
-                            { clear carry flag }
-                                exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_B,$FE,R_CCR)));
-                            {To compensate for not doing a second pass.}
-                            stringdispose(p^.right^.location.reference.symbol);
-                            {Now place the end label.}
-                            exprasmlist^.concat(new(pai_label,init(l)));
-                        end
-                   else
-                        begin
-                           { calculate both operators }
-                           { the complex one first }
-                           firstcomplex(p);
-                           secondpass(p^.left);
-                           {
-                           unnecessary !! PM
-                           set_location(p^.location,p^.left^.location);}
-                           { are too few registers free? }
-                           pushed:=maybe_push(p^.right^.registers32,p);
-                           secondpass(p^.right);
-                           if pushed then restore(p);
-                           { of course not commutative }
-                           if p^.swaped then
-                             swaptree(p);
-                            { SET_IN_BYTE is an inline assembler procedure instead  }
-                            { of a normal procedure, which is *MUCH* faster         }
-                            { Parameters are passed by registers, and FLAGS are set }
-                            { according to the result.                              }
-                            { a0   = address of set                                 }
-                            { d0.b = value to compare with                          }
-                            { CARRY SET IF FOUND ON EXIT                            }
-                            loadsetelement(p^.left);
-                            exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
-                              newreference(p^.right^.location.reference),R_A0)));;
-{                            emitpushreferenceaddr(p^.right^.location.reference);}
-                            del_reference(p^.right^.location.reference);
-                            emitcall('FPC_SET_IN_BYTE',true);
-                            { ungetiftemp(p^.right^.location.reference); }
-                            p^.location.loc:=LOC_FLAGS;
-                            p^.location.resflags:=F_C;
-                        end;
-                end;
-             end;
-      end;
-
-
-{*****************************************************************************
-                              SecondCase
-*****************************************************************************}
-
-    procedure secondcase(var p : ptree);
-
-      var
-         with_sign : boolean;
-         opsize : topsize;
-         jmp_gt,jmp_le,jmp_lee : tasmop;
-         hp : ptree;
-         { register with case expression }
-         hregister : tregister;
-         endlabel,elselabel : pasmlabel;
-
-         { true, if we can omit the range check of the jump table }
-         jumptable_no_range : boolean;
-
-      procedure gentreejmp(p : pcaserecord);
-
-        var
-           lesslabel,greaterlabel : pasmlabel;
-
-      begin
-         emitl(A_LABEL,p^._at);
-         { calculate labels for left and right }
-         if (p^.less=nil) then
-           lesslabel:=elselabel
-         else
-           lesslabel:=p^.less^._at;
-         if (p^.greater=nil) then
-           greaterlabel:=elselabel
-         else
-           greaterlabel:=p^.greater^._at;
-           { calculate labels for left and right }
-         { no range label: }
-         if p^._low=p^._high then
-           begin
-              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._low,hregister)));
-              if greaterlabel=lesslabel then
-                begin
-                   emitl(A_BNE,lesslabel);
-                end
-              else
-                begin
-                   emitl(jmp_le,lesslabel);
-                   emitl(jmp_gt,greaterlabel);
-                end;
-              emitl(A_JMP,p^.statement);
-           end
-         else
-           begin
-              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._low,hregister)));
-              emitl(jmp_le,lesslabel);
-              exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._high,hregister)));
-              emitl(jmp_gt,greaterlabel);
-              emitl(A_JMP,p^.statement);
-           end;
-         if assigned(p^.less) then
-           gentreejmp(p^.less);
-         if assigned(p^.greater) then
-           gentreejmp(p^.greater);
-      end;
-
-      procedure genlinearlist(hp : pcaserecord);
-
-        var
-           first : boolean;
-           last : longint;
-
-        procedure genitem(t : pcaserecord);
-
-          begin
-             if assigned(t^.less) then
-               genitem(t^.less);
-             if t^._low=t^._high then
-               begin
-                  if (t^._low-last > 0) and (t^._low-last < 9) then
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister)))
-                  else
-                  if (t^._low-last = 0) then
-                     exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,hregister)))
-                  else
-                     exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
-                  last:=t^._low;
-
-                  emitl(A_BEQ,t^.statement);
-               end
-             else
-               begin
-                  { it begins with the smallest label, if the value }
-                  { is even smaller then jump immediately to the    }
-                  { ELSE-label                                      }
-                  if first then
-                    begin
-                       if (t^._low-1 > 0) and (t^._low < 9) then
-                          exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister)))
-                       else
-                       if t^._low-1=0 then
-                         exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,hregister)))
-                       else
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-1,hregister)));
-                       if t^._low = 0 then
-                          emitl(A_BLE,elselabel)
-                       else
-                          emitl(jmp_lee,elselabel);
-                    end
-                  { if there is no unused label between the last and the }
-                  { present label then the lower limit can be checked    }
-                  { immediately. else check the range in between:        }
-                  else if (t^._low-last>1)then
-
-                    begin
-                       if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister)))
-                       else
-                         exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
-                       emitl(jmp_lee,elselabel);
-                    end;
-                  exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
-                  emitl(jmp_lee,t^.statement);
-
-                  last:=t^._high;
-               end;
-             first:=false;
-             if assigned(t^.greater) then
-               genitem(t^.greater);
-          end;
-
-        var
-           hr : tregister;
-
-        begin
-           { case register is modified by the list evalution }
-           if (p^.left^.location.loc=LOC_CREGISTER) then
-             begin
-                hr:=getregister32;
-             end;
-           last:=0;
-           first:=true;
-           genitem(hp);
-           emitl(A_JMP,elselabel);
-        end;
-
-      procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
-
-        var
-           table : pasmlabel;
-           last : longint;
-           hr : preference;
-
-        procedure genitem(t : pcaserecord);
-
-          var
-             i : longint;
-
-          begin
-             if assigned(t^.less) then
-               genitem(t^.less);
-             { fill possible hole }
-             for i:=last+1 to t^._low-1 do
-               datasegment^.concat(new(pai_const_symbol,init(elselabel)));
-             for i:=t^._low to t^._high do
-               datasegment^.concat(new(pai_const_symbol,init(t^.statement)));
-              last:=t^._high;
-             if assigned(t^.greater) then
-               genitem(t^.greater);
-          end;
-
-        begin
-           if not(jumptable_no_range) then
-             begin
-                exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,min_,hregister)));
-                { case expr less than min_ => goto elselabel }
-                emitl(jmp_le,elselabel);
-                exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,max_,hregister)));
-                emitl(jmp_gt,elselabel);
-             end;
-           getlabel(table);
-           { extend with sign }
-           if opsize=S_W then
-             begin
-                { word to long - unsigned }
-                exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hregister)));
-             end
-           else if opsize=S_B then
-             begin
-                { byte to long - unsigned }
-                exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hregister)));
-             end;
-           new(hr);
-           reset_reference(hr^);
-           hr^.symbol:=stringdup(table^.name);
-           hr^.offset:=(-min_)*4;
-
-           { add scalefactor *4 to index }
-           exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,hregister)));
-{           hr^.scalefactor:=4; }
-           hr^.base:=getaddressreg;
-           emit_reg_reg(A_MOVE,S_L,hregister,hr^.base);
-           exprasmlist^.concat(new(paicpu,op_ref(A_JMP,S_NO,hr)));
-{          if not(cs_littlesize in aktglobalswitches^ ) then
-             datasegment^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4))); }
-           datasegment^.concat(new(pai_label,init(table)));
-             last:=min_;
-           genitem(hp);
-           if hr^.base <> R_NO then ungetregister(hr^.base);
-           { !!!!!!!
-           if not(cs_littlesize in aktglobalswitches^ ) then
-             exprasmlist^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4)));
-           }
-        end;
-
-      var
-         lv,hv,min_label,max_label,labels : longint;
-         max_linear_list : longint;
-
-      begin
-         getlabel(endlabel);
-         getlabel(elselabel);
-         with_sign:=is_signed(p^.left^.resulttype);
-         if with_sign then
-           begin
-              jmp_gt:=A_BGT;
-              jmp_le:=A_BLT;
-              jmp_lee:=A_BLE;
-           end
-         else
-           begin
-              jmp_gt:=A_BHI;
-              jmp_le:=A_BCS;
-              jmp_lee:=A_BLS;
-           end;
-         cleartempgen;
-         secondpass(p^.left);
-         { determines the size of the operand }
-         { determines the size of the operand }
-         opsize:=bytes2Sxx[p^.left^.resulttype^.size];
-         { copy the case expression to a register }
-         { copy the case expression to a register }
-         case p^.left^.location.loc of
-            LOC_REGISTER,
-            LOC_CREGISTER : hregister:=p^.left^.location.register;
-            LOC_MEM,LOC_REFERENCE : begin
-                                       del_reference(p^.left^.location.reference);
-                                           hregister:=getregister32;
-                                       exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(
-                                         p^.left^.location.reference),hregister)));
-                                    end;
-            else internalerror(2002);
-         end;
-         { now generate the jumps }
-         if cs_optimize in aktglobalswitches  then
-           begin
-              { procedures are empirically passed on }
-              { consumption can also be calculated   }
-              { but does it pay on the different     }
-              { processors?                          }
-              { moreover can the size only be appro- }
-              { ximated as it is not known if rel8,  }
-              { rel16 or rel32 jumps are used        }
-              min_label:=case_get_min(p^.nodes);
-              max_label:=case_get_max(p^.nodes);
-              labels:=case_count_labels(p^.nodes);
-              { can we omit the range check of the jump table }
-              getrange(p^.left^.resulttype,lv,hv);
-              jumptable_no_range:=(lv=min_label) and (hv=max_label);
-
-              { optimize for size ? }
-              if cs_littlesize in aktglobalswitches  then
-                begin
-                   if (labels<=2) or ((max_label-min_label)>3*labels) then
-                     { a linear list is always smaller than a jump tree }
-                     genlinearlist(p^.nodes)
-                   else
-                     { if the labels less or more a continuum then }
-                     genjumptable(p^.nodes,min_label,max_label);
-                end
-              else
-                begin
-                   if jumptable_no_range then
-                     max_linear_list:=4
-                   else
-                     max_linear_list:=2;
-
-                   if (labels<=max_linear_list) then
-                     genlinearlist(p^.nodes)
-                   else
-                     begin
-                        if ((max_label-min_label)>4*labels) then
-                          begin
-                             if labels>16 then
-                               gentreejmp(p^.nodes)
-                             else
-                               genlinearlist(p^.nodes);
-                          end
-                        else
-                          genjumptable(p^.nodes,min_label,max_label);
-                     end;
-                end;
-           end
-         else
-           { it's always not bad }
-           genlinearlist(p^.nodes);
-
-         { now generate the instructions }
-         hp:=p^.right;
-         while assigned(hp) do
-           begin
-              cleartempgen;
-              secondpass(hp^.right);
-              emitl(A_JMP,endlabel);
-              hp:=hp^.left;
-           end;
-         emitl(A_LABEL,elselabel);
-         { ... and the else block }
-         if assigned(p^.elseblock) then
-           begin
-              cleartempgen;
-              secondpass(p^.elseblock);
-           end;
-         emitl(A_LABEL,endlabel);
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.2  2000/07/13 11:32:37  michael
-  + removed logs
-
-}

compiler/old/tcadd.pas

@@ -1,1338 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for add node
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcadd;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstadd(var p : ptree);
-    function isbinaryoverloaded(var p : ptree) : boolean;
-
-
-implementation
-
-    uses
-      globtype,systems,tokens,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-{$ifdef newcg}
-      cgbase,
-{$else newcg}
-      hcodegen,
-{$endif newcg}
-      htypechk,pass_1,
-      cpubase,tccnv
-      ;
-
-    function isbinaryoverloaded(var p : ptree) : boolean;
-
-     var
-         rd,ld   : pdef;
-         t : ptree;
-         optoken : ttoken;
-
-      begin
-        isbinaryoverloaded:=false;
-        { overloaded operator ? }
-        { load easier access variables }
-        rd:=p^.right^.resulttype;
-        ld:=p^.left^.resulttype;
-        if isbinaryoperatoroverloadable(ld,rd,voiddef,p^.treetype) then
-          begin
-             isbinaryoverloaded:=true;
-             {!!!!!!!!! handle paras }
-             case p^.treetype of
-                { the nil as symtable signs firstcalln that this is
-                  an overloaded operator }
-                addn:
-                  optoken:=_PLUS;
-                subn:
-                  optoken:=_MINUS;
-                muln:
-                  optoken:=_STAR;
-                starstarn:
-                  optoken:=_STARSTAR;
-                slashn:
-                  optoken:=_SLASH;
-                ltn:
-                  optoken:=tokens._lt;
-                gtn:
-                  optoken:=tokens._gt;
-                lten:
-                  optoken:=_lte;
-                gten:
-                  optoken:=_gte;
-                equaln,unequaln :
-                  optoken:=_EQUAL;
-                symdifn :
-                  optoken:=_SYMDIF;
-                modn :
-                  optoken:=_OP_MOD;
-                orn :
-                  optoken:=_OP_OR;
-                xorn :
-                  optoken:=_OP_XOR;
-                andn :
-                  optoken:=_OP_AND;
-                divn :
-                  optoken:=_OP_DIV;
-                shln :
-                  optoken:=_OP_SHL;
-                shrn :
-                  optoken:=_OP_SHR;
-                else
-                  exit;
-             end;
-             t:=gencallnode(overloaded_operators[optoken],nil);
-             { we have to convert p^.left and p^.right into
-              callparanodes }
-             if t^.symtableprocentry=nil then
-               begin
-                  CGMessage(parser_e_operator_not_overloaded);
-                  putnode(t);
-               end
-             else
-               begin
-                  inc(t^.symtableprocentry^.refs);
-                  t^.left:=gencallparanode(p^.left,nil);
-                  t^.left:=gencallparanode(p^.right,t^.left);
-                  if p^.treetype=unequaln then
-                   t:=gensinglenode(notn,t);
-                  firstpass(t);
-                  putnode(p);
-                  p:=t;
-               end;
-          end;
-      end;
-
-{*****************************************************************************
-                                FirstAdd
-*****************************************************************************}
-
-{$ifdef fpc}
-{$maxfpuregisters 0}
-{$endif fpc}
-
-    procedure firstadd(var p : ptree);
-
-      procedure make_bool_equal_size(var p:ptree);
-      begin
-        if porddef(p^.left^.resulttype)^.typ>porddef(p^.right^.resulttype)^.typ then
-         begin
-           p^.right:=gentypeconvnode(p^.right,porddef(p^.left^.resulttype));
-           p^.right^.convtyp:=tc_bool_2_int;
-           p^.right^.explizit:=true;
-           firstpass(p^.right);
-         end
-        else
-         if porddef(p^.left^.resulttype)^.typ<porddef(p^.right^.resulttype)^.typ then
-          begin
-            p^.left:=gentypeconvnode(p^.left,porddef(p^.right^.resulttype));
-            p^.left^.convtyp:=tc_bool_2_int;
-            p^.left^.explizit:=true;
-            firstpass(p^.left);
-          end;
-      end;
-
-      var
-         t,hp    : ptree;
-         ot,
-         lt,rt   : ttreetyp;
-         rv,lv   : longint;
-         rvd,lvd : bestreal;
-         resdef,
-         rd,ld   : pdef;
-         tempdef : pdef;
-         concatstrings : boolean;
-
-         { to evalute const sets }
-         resultset : pconstset;
-         i : longint;
-         b : boolean;
-         convdone : boolean;
-         s1,s2 : pchar;
-         l1,l2 : longint;
-
-      begin
-         { first do the two subtrees }
-         firstpass(p^.left);
-         firstpass(p^.right);
-         if codegenerror then
-           exit;
-
-         { convert array constructors to sets, because there is no other operator
-           possible for array constructors }
-         if is_array_constructor(p^.left^.resulttype) then
-           arrayconstructor_to_set(p^.left);
-         if is_array_constructor(p^.right^.resulttype) then
-           arrayconstructor_to_set(p^.right);
-
-         { both left and right need to be valid }
-         set_varstate(p^.left,true);
-         set_varstate(p^.right,true);
-
-         { load easier access variables }
-         lt:=p^.left^.treetype;
-         rt:=p^.right^.treetype;
-         rd:=p^.right^.resulttype;
-         ld:=p^.left^.resulttype;
-         convdone:=false;
-
-         if isbinaryoverloaded(p) then
-           exit;
-         { compact consts }
-
-         { convert int consts to real consts, if the }
-         { other operand is a real const             }
-         if (rt=realconstn) and is_constintnode(p^.left) then
-           begin
-              t:=genrealconstnode(p^.left^.value,p^.right^.resulttype);
-              disposetree(p^.left);
-              p^.left:=t;
-              lt:=realconstn;
-           end;
-         if (lt=realconstn) and is_constintnode(p^.right) then
-           begin
-              t:=genrealconstnode(p^.right^.value,p^.left^.resulttype);
-              disposetree(p^.right);
-              p^.right:=t;
-              rt:=realconstn;
-           end;
-
-       { both are int constants, also allow operations on two equal enums
-         in fpc mode (Needed for conversion of C code) }
-         if ((lt=ordconstn) and (rt=ordconstn)) and
-            ((is_constintnode(p^.left) and is_constintnode(p^.right)) or
-             (is_constboolnode(p^.left) and is_constboolnode(p^.right) and
-              (p^.treetype in [ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn]))) then
-           begin
-              { xor, and, or are handled different from arithmetic }
-              { operations regarding the result type               }
-              { return a boolean for boolean operations (and,xor,or) }
-              if is_constboolnode(p^.left) then
-               resdef:=booldef
-              else if is_64bitint(rd) or is_64bitint(ld) then
-                resdef:=cs64bitdef
-              else
-                resdef:=s32bitdef;
-              lv:=p^.left^.value;
-              rv:=p^.right^.value;
-              case p^.treetype of
-                addn : t:=genintconstnode(lv+rv);
-                subn : t:=genintconstnode(lv-rv);
-                muln : t:=genintconstnode(lv*rv);
-                xorn : t:=genordinalconstnode(lv xor rv,resdef);
-                 orn: t:=genordinalconstnode(lv or rv,resdef);
-                andn: t:=genordinalconstnode(lv and rv,resdef);
-                 ltn : t:=genordinalconstnode(ord(lv<rv),booldef);
-                lten : t:=genordinalconstnode(ord(lv<=rv),booldef);
-                 gtn : t:=genordinalconstnode(ord(lv>rv),booldef);
-                gten : t:=genordinalconstnode(ord(lv>=rv),booldef);
-              equaln : t:=genordinalconstnode(ord(lv=rv),booldef);
-            unequaln : t:=genordinalconstnode(ord(lv<>rv),booldef);
-              slashn : begin
-                       { int/int becomes a real }
-                         if int(rv)=0 then
-                          begin
-                            Message(parser_e_invalid_float_operation);
-                            t:=genrealconstnode(0,bestrealdef^);
-                          end
-                         else
-                          t:=genrealconstnode(int(lv)/int(rv),bestrealdef^);
-                         firstpass(t);
-                       end;
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-
-       { both real constants ? }
-         if (lt=realconstn) and (rt=realconstn) then
-           begin
-              lvd:=p^.left^.value_real;
-              rvd:=p^.right^.value_real;
-              case p^.treetype of
-                 addn : t:=genrealconstnode(lvd+rvd,bestrealdef^);
-                 subn : t:=genrealconstnode(lvd-rvd,bestrealdef^);
-                 muln : t:=genrealconstnode(lvd*rvd,bestrealdef^);
-               starstarn,
-               caretn : begin
-                          if lvd<0 then
-                           begin
-                             Message(parser_e_invalid_float_operation);
-                             t:=genrealconstnode(0,bestrealdef^);
-                           end
-                          else if lvd=0 then
-                            t:=genrealconstnode(1.0,bestrealdef^)
-                          else
-                            t:=genrealconstnode(exp(ln(lvd)*rvd),bestrealdef^);
-                        end;
-               slashn :
-                        begin
-                          if rvd=0 then
-                           begin
-                             Message(parser_e_invalid_float_operation);
-                             t:=genrealconstnode(0,bestrealdef^);
-                           end
-                          else
-                           t:=genrealconstnode(lvd/rvd,bestrealdef^);
-                        end;
-                  ltn : t:=genordinalconstnode(ord(lvd<rvd),booldef);
-                 lten : t:=genordinalconstnode(ord(lvd<=rvd),booldef);
-                  gtn : t:=genordinalconstnode(ord(lvd>rvd),booldef);
-                 gten : t:=genordinalconstnode(ord(lvd>=rvd),booldef);
-               equaln : t:=genordinalconstnode(ord(lvd=rvd),booldef);
-             unequaln : t:=genordinalconstnode(ord(lvd<>rvd),booldef);
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              disposetree(p);
-              p:=t;
-              firstpass(p);
-              exit;
-           end;
-
-       { concating strings ? }
-         concatstrings:=false;
-         s1:=nil;
-         s2:=nil;
-         if (lt=ordconstn) and (rt=ordconstn) and
-            is_char(ld) and is_char(rd) then
-           begin
-              s1:=strpnew(char(byte(p^.left^.value)));
-              s2:=strpnew(char(byte(p^.right^.value)));
-              l1:=1;
-              l2:=1;
-              concatstrings:=true;
-           end
-         else
-           if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
-           begin
-              s1:=getpcharcopy(p^.left);
-              l1:=p^.left^.length;
-              s2:=strpnew(char(byte(p^.right^.value)));
-              l2:=1;
-              concatstrings:=true;
-           end
-         else
-           if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
-           begin
-              s1:=strpnew(char(byte(p^.left^.value)));
-              l1:=1;
-              s2:=getpcharcopy(p^.right);
-              l2:=p^.right^.length;
-              concatstrings:=true;
-           end
-         else if (lt=stringconstn) and (rt=stringconstn) then
-           begin
-              s1:=getpcharcopy(p^.left);
-              l1:=p^.left^.length;
-              s2:=getpcharcopy(p^.right);
-              l2:=p^.right^.length;
-              concatstrings:=true;
-           end;
-
-         { I will need to translate all this to ansistrings !!! }
-         if concatstrings then
-           begin
-              case p^.treetype of
-                 addn :
-                   t:=genpcharconstnode(concatansistrings(s1,s2,l1,l2),l1+l2);
-                 ltn :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<0),booldef);
-                 lten :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<=0),booldef);
-                 gtn :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)>0),booldef);
-                 gten :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)>=0),booldef);
-                 equaln :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)=0),booldef);
-                 unequaln :
-                   t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<>0),booldef);
-              end;
-              ansistringdispose(s1,l1);
-              ansistringdispose(s2,l2);
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-
-       { if both are orddefs then check sub types }
-         if (ld^.deftype=orddef) and (rd^.deftype=orddef) then
-           begin
-           { 2 booleans ? }
-             if is_boolean(ld) and is_boolean(rd) then
-              begin
-                if (cs_full_boolean_eval in aktlocalswitches) or
-                   (p^.treetype in [xorn,ltn,lten,gtn,gten]) then
-                  begin
-                     make_bool_equal_size(p);
-                    if (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) and
-                       (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) then
-                      calcregisters(p,2,0,0)
-                    else
-                      calcregisters(p,1,0,0);
-                  end
-                else
-                  case p^.treetype of
-                    andn,
-                    orn:
-                      begin
-                        make_bool_equal_size(p);
-                        calcregisters(p,0,0,0);
-                        p^.location.loc:=LOC_JUMP;
-                      end;
-                    unequaln,
-                    equaln:
-                      begin
-                        make_bool_equal_size(p);
-                        { Remove any compares with constants }
-                        if (p^.left^.treetype=ordconstn) then
-                         begin
-                           hp:=p^.right;
-                           b:=(p^.left^.value<>0);
-                           ot:=p^.treetype;
-                           disposetree(p^.left);
-                           putnode(p);
-                           p:=hp;
-                           if (not(b) and (ot=equaln)) or
-                              (b and (ot=unequaln)) then
-                            begin
-                              p:=gensinglenode(notn,p);
-                              firstpass(p);
-                            end;
-                           exit;
-                         end;
-                        if (p^.right^.treetype=ordconstn) then
-                         begin
-                           hp:=p^.left;
-                           b:=(p^.right^.value<>0);
-                           ot:=p^.treetype;
-                           disposetree(p^.right);
-                           putnode(p);
-                           p:=hp;
-                           if (not(b) and (ot=equaln)) or
-                              (b and (ot=unequaln)) then
-                            begin
-                              p:=gensinglenode(notn,p);
-                              firstpass(p);
-                            end;
-                           exit;
-                         end;
-                        if (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) and
-                          (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) then
-                          calcregisters(p,2,0,0)
-                        else
-                          calcregisters(p,1,0,0);
-                      end;
-                  else
-                    CGMessage(type_e_mismatch);
-                end;
-(*
-                { these one can't be in flags! }
-
-                Yes they can, secondadd converts the loc_flags to a register.
-                The typeconversions below are simply removed by firsttypeconv()
-                because the resulttype of p^.left = p^.left^.resulttype
-                (surprise! :) (JM)
-
-                if p^.treetype in [xorn,unequaln,equaln] then
-                  begin
-                     if p^.left^.location.loc=LOC_FLAGS then
-                       begin
-                          p^.left:=gentypeconvnode(p^.left,porddef(p^.left^.resulttype));
-                          p^.left^.convtyp:=tc_bool_2_int;
-                          p^.left^.explizit:=true;
-                          firstpass(p^.left);
-                       end;
-                     if p^.right^.location.loc=LOC_FLAGS then
-                       begin
-                          p^.right:=gentypeconvnode(p^.right,porddef(p^.right^.resulttype));
-                          p^.right^.convtyp:=tc_bool_2_int;
-                          p^.right^.explizit:=true;
-                          firstpass(p^.right);
-                       end;
-                     { readjust registers }
-                     calcregisters(p,1,0,0);
-                  end;
-*)
-                convdone:=true;
-              end
-             else
-             { Both are chars? only convert to shortstrings for addn }
-              if is_char(rd) and is_char(ld) then
-               begin
-                 if p^.treetype=addn then
-                   begin
-                     p^.left:=gentypeconvnode(p^.left,cshortstringdef);
-                     p^.right:=gentypeconvnode(p^.right,cshortstringdef);
-                     firstpass(p^.left);
-                     firstpass(p^.right);
-                     { here we call STRCOPY }
-                     procinfo^.flags:=procinfo^.flags or pi_do_call;
-                     calcregisters(p,0,0,0);
-                     p^.location.loc:=LOC_MEM;
-                   end
-                 else
-                   calcregisters(p,1,0,0);
-                 convdone:=true;
-               end
-              { is there a 64 bit type ? }
-             else if ((porddef(rd)^.typ=s64bit) or (porddef(ld)^.typ=s64bit)) and
-               { the / operator is handled later }
-               (p^.treetype<>slashn) then
-               begin
-                  if (porddef(ld)^.typ<>s64bit) then
-                    begin
-                      p^.left:=gentypeconvnode(p^.left,cs64bitdef);
-                      firstpass(p^.left);
-                    end;
-                  if (porddef(rd)^.typ<>s64bit) then
-                    begin
-                       p^.right:=gentypeconvnode(p^.right,cs64bitdef);
-                       firstpass(p^.right);
-                    end;
-                  calcregisters(p,2,0,0);
-                  convdone:=true;
-               end
-             else if ((porddef(rd)^.typ=u64bit) or (porddef(ld)^.typ=u64bit)) and
-               { the / operator is handled later }
-               (p^.treetype<>slashn) then
-               begin
-                  if (porddef(ld)^.typ<>u64bit) then
-                    begin
-                      p^.left:=gentypeconvnode(p^.left,cu64bitdef);
-                      firstpass(p^.left);
-                    end;
-                  if (porddef(rd)^.typ<>u64bit) then
-                    begin
-                       p^.right:=gentypeconvnode(p^.right,cu64bitdef);
-                       firstpass(p^.right);
-                    end;
-                  calcregisters(p,2,0,0);
-                  convdone:=true;
-               end
-             else
-              { is there a cardinal? }
-              if ((porddef(rd)^.typ=u32bit) or (porddef(ld)^.typ=u32bit)) and
-               { the / operator is handled later }
-               (p^.treetype<>slashn) then
-               begin
-                 { convert constants to u32bit }
-{$ifndef cardinalmulfix}
-                 if (porddef(ld)^.typ<>u32bit) then
-                  begin
-                    { s32bit will be used for when the other is also s32bit }
-
-  { the following line doesn't make any sense: it's the same as        }
-  {  if ((porddef(rd)^.typ=u32bit) or (porddef(ld)^.typ=u32bit)) and   }
-  {      (porddef(ld)^.typ<>u32bit) and (porddef(rd)^.typ=s32bit) then }
-  { which can be simplified to                                         }
-  {  if ((porddef(rd)^.typ=u32bit) and (porddef(rd)^.typ=s32bit) then  }
-  { which can never be true (JM)                                       }
-                    if (porddef(rd)^.typ=s32bit) and (lt<>ordconstn) then
-                     p^.left:=gentypeconvnode(p^.left,s32bitdef)
-                    else
-                     p^.left:=gentypeconvnode(p^.left,u32bitdef);
-                    firstpass(p^.left);
-                  end;
-                 if (porddef(rd)^.typ<>u32bit) then
-                  begin
-                    { s32bit will be used for when the other is also s32bit }
-                    if (porddef(ld)^.typ=s32bit) and (rt<>ordconstn) then
-                     p^.right:=gentypeconvnode(p^.right,s32bitdef)
-                    else
-                     p^.right:=gentypeconvnode(p^.right,u32bitdef);
-                    firstpass(p^.right);
-                  end;
-{$else cardinalmulfix}
-                 { only do a conversion if the nodes have different signs }
-                 if (porddef(rd)^.typ=u32bit) xor (porddef(ld)^.typ=u32bit) then
-                   if (porddef(rd)^.typ=u32bit) then
-                     begin
-                     { can we make them both unsigned? }
-                       if (porddef(ld)^.typ in [u8bit,u16bit]) or
-                          (is_constintnode(p^.left) and
-                           (p^.treetype <> subn) and
-                           (p^.left^.value > 0)) then
-                         p^.left:=gentypeconvnode(p^.left,u32bitdef)
-                       else
-                         p^.left:=gentypeconvnode(p^.left,s32bitdef);
-                       firstpass(p^.left);
-                     end
-                   else {if (porddef(ld)^.typ=u32bit) then}
-                     begin
-                     { can we make them both unsigned? }
-                       if (porddef(rd)^.typ in [u8bit,u16bit]) or
-                          (is_constintnode(p^.right) and
-                           (p^.right^.value > 0)) then
-                         p^.right:=gentypeconvnode(p^.right,u32bitdef)
-                       else
-                         p^.right:=gentypeconvnode(p^.right,s32bitdef);
-                       firstpass(p^.right);
-                     end;
-{$endif cardinalmulfix}
-                 calcregisters(p,1,0,0);
-                 { for unsigned mul we need an extra register }
-{                 p^.registers32:=p^.left^.registers32+p^.right^.registers32; }
-                 if p^.treetype=muln then
-                  inc(p^.registers32);
-                 convdone:=true;
-               end;
-           end
-         else
-
-         { left side a setdef, must be before string processing,
-           else array constructor can be seen as array of char (PFV) }
-           if (ld^.deftype=setdef) {or is_array_constructor(ld)} then
-             begin
-             { trying to add a set element? }
-                if (p^.treetype=addn) and (rd^.deftype<>setdef) then
-                 begin
-                   if (rt=setelementn) then
-                    begin
-                      if not(is_equal(psetdef(ld)^.elementtype.def,rd)) then
-                       CGMessage(type_e_set_element_are_not_comp);
-                    end
-                   else
-                    CGMessage(type_e_mismatch)
-                 end
-                else
-                 begin
-                   if not(p^.treetype in [addn,subn,symdifn,muln,equaln,unequaln
-{$IfNDef NoSetInclusion}
-                                          ,lten,gten
-{$EndIf NoSetInclusion}
-                   ]) then
-                    CGMessage(type_e_set_operation_unknown);
-                 { right def must be a also be set }
-                   if (rd^.deftype<>setdef) or not(is_equal(rd,ld)) then
-                    CGMessage(type_e_set_element_are_not_comp);
-                 end;
-
-                { ranges require normsets }
-                if (psetdef(ld)^.settype=smallset) and
-                   (rt=setelementn) and
-                   assigned(p^.right^.right) then
-                 begin
-                   { generate a temporary normset def, it'll be destroyed
-                     when the symtable is unloaded }
-                   tempdef:=new(psetdef,init(psetdef(ld)^.elementtype.def,255));
-                   p^.left:=gentypeconvnode(p^.left,tempdef);
-                   firstpass(p^.left);
-                   ld:=p^.left^.resulttype;
-                 end;
-
-                { if the destination is not a smallset then insert a typeconv
-                  which loads a smallset into a normal set }
-                if (psetdef(ld)^.settype<>smallset) and
-                   (psetdef(rd)^.settype=smallset) then
-                 begin
-                   if (p^.right^.treetype=setconstn) then
-                     begin
-                        t:=gensetconstnode(p^.right^.value_set,psetdef(p^.left^.resulttype));
-                        t^.left:=p^.right^.left;
-                        putnode(p^.right);
-                        p^.right:=t;
-                     end
-                   else
-                     p^.right:=gentypeconvnode(p^.right,psetdef(p^.left^.resulttype));
-                   firstpass(p^.right);
-                 end;
-
-                { do constant evaluation }
-                if (p^.right^.treetype=setconstn) and
-                   not assigned(p^.right^.left) and
-                   (p^.left^.treetype=setconstn) and
-                   not assigned(p^.left^.left) then
-                  begin
-                     new(resultset);
-                     case p^.treetype of
-                        addn : begin
-                                  for i:=0 to 31 do
-                                    resultset^[i]:=
-                                      p^.right^.value_set^[i] or p^.left^.value_set^[i];
-                                  t:=gensetconstnode(resultset,psetdef(ld));
-                               end;
-                        muln : begin
-                                  for i:=0 to 31 do
-                                    resultset^[i]:=
-                                      p^.right^.value_set^[i] and p^.left^.value_set^[i];
-                                  t:=gensetconstnode(resultset,psetdef(ld));
-                               end;
-                        subn : begin
-                                  for i:=0 to 31 do
-                                    resultset^[i]:=
-                                      p^.left^.value_set^[i] and not(p^.right^.value_set^[i]);
-                                  t:=gensetconstnode(resultset,psetdef(ld));
-                               end;
-                     symdifn : begin
-                                  for i:=0 to 31 do
-                                    resultset^[i]:=
-                                      p^.left^.value_set^[i] xor p^.right^.value_set^[i];
-                                  t:=gensetconstnode(resultset,psetdef(ld));
-                               end;
-                    unequaln : begin
-                                 b:=true;
-                                 for i:=0 to 31 do
-                                  if p^.right^.value_set^[i]=p^.left^.value_set^[i] then
-                                   begin
-                                     b:=false;
-                                     break;
-                                   end;
-                                 t:=genordinalconstnode(ord(b),booldef);
-                               end;
-                      equaln : begin
-                                 b:=true;
-                                 for i:=0 to 31 do
-                                  if p^.right^.value_set^[i]<>p^.left^.value_set^[i] then
-                                   begin
-                                     b:=false;
-                                     break;
-                                   end;
-                                 t:=genordinalconstnode(ord(b),booldef);
-                               end;
-{$IfNDef NoSetInclusion}
-                       lten : Begin
-                                b := true;
-                                For i := 0 to 31 Do
-                                  If (p^.right^.value_set^[i] And p^.left^.value_set^[i]) <>
-                                      p^.left^.value_set^[i] Then
-                                    Begin
-                                      b := false;
-                                      Break
-                                    End;
-                                t := genordinalconstnode(ord(b),booldef);
-                              End;
-                       gten : Begin
-                                b := true;
-                                For i := 0 to 31 Do
-                                  If (p^.left^.value_set^[i] And p^.right^.value_set^[i]) <>
-                                      p^.right^.value_set^[i] Then
-                                    Begin
-                                      b := false;
-                                      Break
-                                    End;
-                                t := genordinalconstnode(ord(b),booldef);
-                              End;
-{$EndIf NoSetInclusion}
-                     end;
-                     dispose(resultset);
-                     disposetree(p);
-                     p:=t;
-                     firstpass(p);
-                     exit;
-                  end
-                else
-                 if psetdef(ld)^.settype=smallset then
-                  begin
-                     { are we adding set elements ? }
-                     if p^.right^.treetype=setelementn then
-                       calcregisters(p,2,0,0)
-                     else
-                       calcregisters(p,1,0,0);
-                     p^.location.loc:=LOC_REGISTER;
-                  end
-                 else
-                  begin
-                     calcregisters(p,0,0,0);
-                     { here we call SET... }
-                     procinfo^.flags:=procinfo^.flags or pi_do_call;
-                     p^.location.loc:=LOC_MEM;
-                  end;
-              convdone:=true;
-            end
-         else
-           { compare pchar to char arrays by addresses
-             like BP/Delphi }
-           if (is_pchar(ld) and is_chararray(rd)) or
-              (is_pchar(rd) and is_chararray(ld)) then
-             begin
-               if is_chararray(rd) then
-                 begin
-                   p^.right:=gentypeconvnode(p^.right,ld);
-                   firstpass(p^.right);
-                 end
-               else
-                 begin
-                   p^.left:=gentypeconvnode(p^.left,rd);
-                   firstpass(p^.left);
-                 end;
-               p^.location.loc:=LOC_REGISTER;
-               calcregisters(p,1,0,0);
-               convdone:=true;
-             end
-         else
-           { is one of the operands a string?,
-             chararrays are also handled as strings (after conversion) }
-           if (rd^.deftype=stringdef) or (ld^.deftype=stringdef) or
-              ((is_chararray(rd) or is_char(rd)) and
-               (is_chararray(ld) or is_char(ld))) then
-            begin
-              if is_widestring(rd) or is_widestring(ld) then
-                begin
-                   if not(is_widestring(rd)) then
-                     p^.right:=gentypeconvnode(p^.right,cwidestringdef);
-                   if not(is_widestring(ld)) then
-                     p^.left:=gentypeconvnode(p^.left,cwidestringdef);
-                   p^.resulttype:=cwidestringdef;
-                   { this is only for add, the comparisaion is handled later }
-                   p^.location.loc:=LOC_REGISTER;
-                end
-              else if is_ansistring(rd) or is_ansistring(ld) then
-                begin
-                   if not(is_ansistring(rd)) then
-                     p^.right:=gentypeconvnode(p^.right,cansistringdef);
-                   if not(is_ansistring(ld)) then
-                     p^.left:=gentypeconvnode(p^.left,cansistringdef);
-                   { we use ansistrings so no fast exit here }
-                   procinfo^.no_fast_exit:=true;
-                   p^.resulttype:=cansistringdef;
-                   { this is only for add, the comparisaion is handled later }
-                   p^.location.loc:=LOC_REGISTER;
-                end
-              else if is_longstring(rd) or is_longstring(ld) then
-                begin
-                   if not(is_longstring(rd)) then
-                     p^.right:=gentypeconvnode(p^.right,clongstringdef);
-                   if not(is_longstring(ld)) then
-                     p^.left:=gentypeconvnode(p^.left,clongstringdef);
-                   p^.resulttype:=clongstringdef;
-                   { this is only for add, the comparisaion is handled later }
-                   p^.location.loc:=LOC_MEM;
-                end
-              else
-                begin
-                   if not(is_shortstring(rd))
-{$ifdef newoptimizations2}
-{$ifdef i386}
-                      { shortstring + char handled seperately  (JM) }
-                      and (not(cs_optimize in aktglobalswitches) or
-                           (p^.treetype <> addn) or not(is_char(rd)))
-{$endif i386}
-{$endif newoptimizations2}
-                    then
-                      p^.right:=gentypeconvnode(p^.right,cshortstringdef);
-                   if not(is_shortstring(ld)) then
-                     p^.left:=gentypeconvnode(p^.left,cshortstringdef);
-                   p^.resulttype:=cshortstringdef;
-                   { this is only for add, the comparisaion is handled later }
-                   p^.location.loc:=LOC_MEM;
-                end;
-              { only if there is a type cast we need to do again }
-              { the first pass                             }
-              if p^.left^.treetype=typeconvn then
-                firstpass(p^.left);
-              if p^.right^.treetype=typeconvn then
-                firstpass(p^.right);
-              { here we call STRCONCAT or STRCMP or STRCOPY }
-              procinfo^.flags:=procinfo^.flags or pi_do_call;
-              if p^.location.loc=LOC_MEM then
-                calcregisters(p,0,0,0)
-              else
-                calcregisters(p,1,0,0);
-{$ifdef newoptimizations2}
-{$ifdef i386}
-              { not always necessary, only if it is not a constant char and }
-              { not a regvar, but don't know how to check this here (JM)    }
-              if is_char(rd) then
-                inc(p^.registers32);
-{$endif i386}
-{$endif newoptimizations2}
-              convdone:=true;
-           end
-         else
-
-         { is one a real float ? }
-           if (rd^.deftype=floatdef) or (ld^.deftype=floatdef) then
-            begin
-            { if one is a fixed, then convert to f32bit }
-              if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ=f32bit)) or
-                 ((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ=f32bit)) then
-               begin
-                 if not is_integer(rd) or (p^.treetype<>muln) then
-                   p^.right:=gentypeconvnode(p^.right,s32fixeddef);
-                 if not is_integer(ld) or (p^.treetype<>muln) then
-                   p^.left:=gentypeconvnode(p^.left,s32fixeddef);
-                 firstpass(p^.left);
-                 firstpass(p^.right);
-                 calcregisters(p,1,0,0);
-                 p^.location.loc:=LOC_REGISTER;
-               end
-              else
-              { convert both to bestreal }
-                begin
-                  p^.right:=gentypeconvnode(p^.right,bestrealdef^);
-                  p^.left:=gentypeconvnode(p^.left,bestrealdef^);
-                  firstpass(p^.left);
-                  firstpass(p^.right);
-                  calcregisters(p,0,1,0);
-                  p^.location.loc:=LOC_FPU;
-                end;
-              convdone:=true;
-            end
-         else
-
-         { pointer comperation and subtraction }
-           if (rd^.deftype=pointerdef) and (ld^.deftype=pointerdef) then
-            begin
-              p^.location.loc:=LOC_REGISTER;
-              { p^.right:=gentypeconvnode(p^.right,ld); }
-              { firstpass(p^.right); }
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln :
-                   begin
-                      if is_equal(p^.right^.resulttype,voidpointerdef) then
-                        begin
-                           p^.right:=gentypeconvnode(p^.right,ld);
-                           firstpass(p^.right);
-                        end
-                      else if is_equal(p^.left^.resulttype,voidpointerdef) then
-                        begin
-                           p^.left:=gentypeconvnode(p^.left,rd);
-                           firstpass(p^.left);
-                        end
-                      else if not(is_equal(ld,rd)) then
-                        CGMessage(type_e_mismatch);
-                   end;
-                 ltn,lten,gtn,gten:
-                   begin
-                      if is_equal(p^.right^.resulttype,voidpointerdef) then
-                        begin
-                           p^.right:=gentypeconvnode(p^.right,ld);
-                           firstpass(p^.right);
-                        end
-                      else if is_equal(p^.left^.resulttype,voidpointerdef) then
-                        begin
-                           p^.left:=gentypeconvnode(p^.left,rd);
-                           firstpass(p^.left);
-                        end
-                      else if not(is_equal(ld,rd)) then
-                        CGMessage(type_e_mismatch);
-                      if not(cs_extsyntax in aktmoduleswitches) then
-                        CGMessage(type_e_mismatch);
-                   end;
-                 subn:
-                   begin
-                      if not(is_equal(ld,rd)) then
-                        CGMessage(type_e_mismatch);
-                      if not(cs_extsyntax in aktmoduleswitches) then
-                        CGMessage(type_e_mismatch);
-                      p^.resulttype:=s32bitdef;
-                      exit;
-                   end;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-           end
-         else
-
-           if (rd^.deftype=objectdef) and (ld^.deftype=objectdef) and
-              pobjectdef(rd)^.is_class and pobjectdef(ld)^.is_class then
-            begin
-              p^.location.loc:=LOC_REGISTER;
-              if pobjectdef(rd)^.is_related(pobjectdef(ld)) then
-                p^.right:=gentypeconvnode(p^.right,ld)
-              else
-                p^.left:=gentypeconvnode(p^.left,rd);
-              firstpass(p^.right);
-              firstpass(p^.left);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-           if (rd^.deftype=classrefdef) and (ld^.deftype=classrefdef) then
-            begin
-              p^.location.loc:=LOC_REGISTER;
-              if pobjectdef(pclassrefdef(rd)^.pointertype.def)^.is_related(pobjectdef(
-                pclassrefdef(ld)^.pointertype.def)) then
-                p^.right:=gentypeconvnode(p^.right,ld)
-              else
-                p^.left:=gentypeconvnode(p^.left,rd);
-              firstpass(p^.right);
-              firstpass(p^.left);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-           end
-         else
-
-         { allows comperasion with nil pointer }
-           if (rd^.deftype=objectdef) and
-              pobjectdef(rd)^.is_class then
-            begin
-              p^.location.loc:=LOC_REGISTER;
-              p^.left:=gentypeconvnode(p^.left,rd);
-              firstpass(p^.left);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-           if (ld^.deftype=objectdef) and
-              pobjectdef(ld)^.is_class then
-            begin
-              p^.location.loc:=LOC_REGISTER;
-              p^.right:=gentypeconvnode(p^.right,ld);
-              firstpass(p^.right);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-           if (rd^.deftype=classrefdef) then
-            begin
-              p^.left:=gentypeconvnode(p^.left,rd);
-              firstpass(p^.left);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-           if (ld^.deftype=classrefdef) then
-            begin
-              p^.right:=gentypeconvnode(p^.right,ld);
-              firstpass(p^.right);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                equaln,unequaln : ;
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-           end
-         else
-
-         { support procvar=nil,procvar<>nil }
-           if ((ld^.deftype=procvardef) and (rt=niln)) or
-              ((rd^.deftype=procvardef) and (lt=niln)) then
-            begin
-              calcregisters(p,1,0,0);
-              p^.location.loc:=LOC_REGISTER;
-              case p^.treetype of
-                 equaln,unequaln : ;
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-{$ifdef SUPPORT_MMX}
-           if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
-             is_mmx_able_array(rd) and is_equal(ld,rd) then
-            begin
-              firstpass(p^.right);
-              firstpass(p^.left);
-              case p^.treetype of
-                addn,subn,xorn,orn,andn:
-                  ;
-                { mul is a little bit restricted }
-                muln:
-                  if not(mmx_type(p^.left^.resulttype) in
-                    [mmxu16bit,mmxs16bit,mmxfixed16]) then
-                    CGMessage(type_e_mismatch);
-                else
-                  CGMessage(type_e_mismatch);
-              end;
-              p^.location.loc:=LOC_MMXREGISTER;
-              calcregisters(p,0,0,1);
-              convdone:=true;
-            end
-          else
-{$endif SUPPORT_MMX}
-
-           { this is a little bit dangerous, also the left type }
-           { should be checked! This broke the mmx support      }
-           if (rd^.deftype=pointerdef) or
-             is_zero_based_array(rd) then
-            begin
-              if is_zero_based_array(rd) then
-                begin
-                   p^.resulttype:=new(ppointerdef,init(parraydef(rd)^.elementtype));
-                   p^.right:=gentypeconvnode(p^.right,p^.resulttype);
-                   firstpass(p^.right);
-                end;
-              p^.location.loc:=LOC_REGISTER;
-              p^.left:=gentypeconvnode(p^.left,s32bitdef);
-              firstpass(p^.left);
-              calcregisters(p,1,0,0);
-              if p^.treetype=addn then
-                begin
-                  if not(cs_extsyntax in aktmoduleswitches) or
-                    (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
-                    CGMessage(type_e_mismatch);
-                  { Dirty hack, to support multiple firstpasses (PFV) }
-                  if (p^.resulttype=nil) and
-                     (rd^.deftype=pointerdef) and
-                     (ppointerdef(rd)^.pointertype.def^.size>1) then
-                   begin
-                     p^.left:=gennode(muln,p^.left,genordinalconstnode(ppointerdef(rd)^.pointertype.def^.size,s32bitdef));
-                     firstpass(p^.left);
-                   end;
-                end
-              else
-                CGMessage(type_e_mismatch);
-              convdone:=true;
-            end
-         else
-
-           if (ld^.deftype=pointerdef) or
-             is_zero_based_array(ld) then
-            begin
-              if is_zero_based_array(ld) then
-                begin
-                   p^.resulttype:=new(ppointerdef,init(parraydef(ld)^.elementtype));
-                   p^.left:=gentypeconvnode(p^.left,p^.resulttype);
-                   firstpass(p^.left);
-                end;
-              p^.location.loc:=LOC_REGISTER;
-              p^.right:=gentypeconvnode(p^.right,s32bitdef);
-              firstpass(p^.right);
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                addn,subn : begin
-                              if not(cs_extsyntax in aktmoduleswitches) or
-                                 (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
-                               CGMessage(type_e_mismatch);
-                              { Dirty hack, to support multiple firstpasses (PFV) }
-                              if (p^.resulttype=nil) and
-                                 (ld^.deftype=pointerdef) and
-                                 (ppointerdef(ld)^.pointertype.def^.size>1) then
-                               begin
-                                 p^.right:=gennode(muln,p^.right,
-                                   genordinalconstnode(ppointerdef(ld)^.pointertype.def^.size,s32bitdef));
-                                 firstpass(p^.right);
-                               end;
-                            end;
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-           end
-         else
-
-           if (rd^.deftype=procvardef) and (ld^.deftype=procvardef) and is_equal(rd,ld) then
-            begin
-              calcregisters(p,1,0,0);
-              p^.location.loc:=LOC_REGISTER;
-              case p^.treetype of
-                 equaln,unequaln : ;
-              else
-                CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end
-         else
-
-           if (ld^.deftype=enumdef) and (rd^.deftype=enumdef) then
-            begin
-              if not(is_equal(ld,rd)) then
-                begin
-                   p^.right:=gentypeconvnode(p^.right,ld);
-                   firstpass(p^.right);
-                end;
-              calcregisters(p,1,0,0);
-              case p^.treetype of
-                 equaln,unequaln,
-                 ltn,lten,gtn,gten : ;
-                 else CGMessage(type_e_mismatch);
-              end;
-              convdone:=true;
-            end;
-
-         { the general solution is to convert to 32 bit int }
-         if not convdone then
-           begin
-              { but an int/int gives real/real! }
-              if p^.treetype=slashn then
-                begin
-                   CGMessage(type_h_use_div_for_int);
-                   p^.right:=gentypeconvnode(p^.right,bestrealdef^);
-                   p^.left:=gentypeconvnode(p^.left,bestrealdef^);
-                   firstpass(p^.left);
-                   firstpass(p^.right);
-                   { maybe we need an integer register to save }
-                   { a reference                               }
-                   if ((p^.left^.location.loc<>LOC_FPU) or
-                       (p^.right^.location.loc<>LOC_FPU)) and
-                       (p^.left^.registers32=p^.right^.registers32) then
-                     calcregisters(p,1,1,0)
-                   else
-                     calcregisters(p,0,1,0);
-                   p^.location.loc:=LOC_FPU;
-                end
-              else
-                begin
-                   p^.right:=gentypeconvnode(p^.right,s32bitdef);
-                   p^.left:=gentypeconvnode(p^.left,s32bitdef);
-                   firstpass(p^.left);
-                   firstpass(p^.right);
-                   calcregisters(p,1,0,0);
-                   p^.location.loc:=LOC_REGISTER;
-                end;
-           end;
-
-         if codegenerror then
-           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' }
-         case p^.treetype of
-            ltn,lten,gtn,gten,equaln,unequaln:
-              begin
-                 if (not assigned(p^.resulttype)) or
-                   (p^.resulttype^.deftype=stringdef) then
-                   p^.resulttype:=booldef;
-                 if is_64bitint(p^.left^.resulttype) then
-                   p^.location.loc:=LOC_JUMP
-                 else
-                   p^.location.loc:=LOC_FLAGS;
-              end;
-            xorn:
-              begin
-                if not assigned(p^.resulttype) then
-                  p^.resulttype:=p^.left^.resulttype;
-                 p^.location.loc:=LOC_REGISTER;
-              end;
-            addn:
-              begin
-                if not assigned(p^.resulttype) then
-                 begin
-                 { for strings, return is always a 255 char string }
-                   if is_shortstring(p^.left^.resulttype) then
-                     p^.resulttype:=cshortstringdef
-                   else
-                    p^.resulttype:=p^.left^.resulttype;
-                 end;
-              end;
-{$ifdef cardinalmulfix}
-            muln:
-  { if we multiply an unsigned with a signed number, the result is signed  }
-  { in the other cases, the result remains signed or unsigned depending on }
-  { the multiplication factors (JM)                                        }
-              if (p^.left^.resulttype^.deftype = orddef) and
-                 (p^.right^.resulttype^.deftype = orddef) and
-                 is_signed(p^.right^.resulttype) then
-                p^.resulttype := p^.right^.resulttype
-              else p^.resulttype := p^.left^.resulttype;
-(*
-            subn:
- { if we substract a u32bit from a positive constant, the result becomes }
- { s32bit as well (JM)                                                   }
-              begin
-                if (p^.right^.resulttype^.deftype = orddef) and
-                   (p^.left^.resulttype^.deftype = orddef) and
-                   (porddef(p^.right^.resulttype)^.typ = u32bit) and
-                   is_constintnode(p^.left) and
-{                   (porddef(p^.left^.resulttype)^.typ <> u32bit) and}
-                   (p^.left^.value > 0) then
-                  begin
-                    p^.left := gentypeconvnode(p^.left,u32bitdef);
-                    firstpass(p^.left);
-                  end;
-                p^.resulttype:=p^.left^.resulttype;
-              end;
-*)
-{$endif cardinalmulfix}
-            else
-              p^.resulttype:=p^.left^.resulttype;
-         end;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:57  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.11  2000/09/24 21:19:52  peter
-    * delphi compile fixes
-
-  Revision 1.10  2000/09/21 12:22:17  jonas
-    * put piece of code between -dnewoptimizations2 since it wasn't
-      necessary otherwise
-
-  Revision 1.9  2000/09/21 11:30:49  jonas
-    + support for full boolean evaluation (b+/b-), default remains short
-      circuit boolean evaluation
-
-  Revision 1.8  2000/09/10 20:19:23  peter
-    * fixed crash with smallset -> normalset conversion (merged)
-
-  Revision 1.7  2000/08/29 08:24:45  jonas
-    * some modifications to -dcardinalmulfix code
-
-  Revision 1.6  2000/08/27 16:11:54  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.5  2000/08/17 12:03:48  florian
-    * fixed several problems with the int64 constants
-
-  Revision 1.4  2000/07/27 09:19:37  jonas
-    * removed obsolete typeconversion (it got removed by the compiler in
-      firsttypeconv anyway) (merged from fixes branch)
-
-  Revision 1.3  2000/07/14 05:11:49  michael
-  + Patch to 1.1
-
-  Revision 1.2  2000/07/13 11:32:50  michael
-  + removed logs
-
-}

compiler/old/tccal.pas

@@ -1,1369 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for call nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tccal;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      symtable,tree;
-
-
-    procedure gen_high_tree(p:ptree;openstring:boolean);
-
-    procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean);
-    procedure firstcalln(var p : ptree);
-    procedure firstprocinline(var p : ptree);
-
-
-implementation
-
-    uses
-      cutils,globtype,systems,
-      cobjects,verbose,globals,
-      symconst,aasm,types,
-      htypechk,pass_1,cpubase
-{$ifdef newcg}
-      ,cgbase
-      ,tgobj
-{$else newcg}
-      ,hcodegen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$ifdef m68k}
-      ,tgen68k
-{$endif m68k}
-{$endif newcg}
-      ;
-
-{*****************************************************************************
-                             FirstCallParaN
-*****************************************************************************}
-
-    procedure gen_high_tree(p:ptree;openstring:boolean);
-      var
-        len : longint;
-        st  : psymtable;
-        loadconst : boolean;
-      begin
-        if assigned(p^.hightree) then
-         exit;
-        len:=-1;
-        loadconst:=true;
-        case p^.left^.resulttype^.deftype of
-          arraydef :
-            begin
-              if is_open_array(p^.left^.resulttype) or
-                 is_array_of_const(p^.left^.resulttype) then
-               begin
-                 st:=p^.left^.symtable;
-                 getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                 p^.hightree:=genloadnode(pvarsym(srsym),st);
-                 loadconst:=false;
-               end
-              else
-                begin
-                  { this is an empty constructor }
-                  len:=parraydef(p^.left^.resulttype)^.highrange-
-                       parraydef(p^.left^.resulttype)^.lowrange;
-                end;
-            end;
-          stringdef :
-            begin
-              if openstring then
-               begin
-                 if is_open_string(p^.left^.resulttype) then
-                  begin
-                    st:=p^.left^.symtable;
-                    getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                    p^.hightree:=genloadnode(pvarsym(srsym),st);
-                    loadconst:=false;
-                  end
-                 else
-                  len:=pstringdef(p^.left^.resulttype)^.len;
-               end
-              else
-             { passing a string to an array of char }
-               begin
-                 if (p^.left^.treetype=stringconstn) then
-                   begin
-                     len:=str_length(p^.left);
-                     if len>0 then
-                      dec(len);
-                   end
-                 else
-                   begin
-                     p^.hightree:=gennode(subn,geninlinenode(in_length_string,false,getcopy(p^.left)),
-                                               genordinalconstnode(1,s32bitdef));
-                     firstpass(p^.hightree);
-                     p^.hightree:=gentypeconvnode(p^.hightree,s32bitdef);
-                     loadconst:=false;
-                   end;
-               end;
-           end;
-        else
-          len:=0;
-        end;
-        if loadconst then
-          p^.hightree:=genordinalconstnode(len,s32bitdef);
-        firstpass(p^.hightree);
-      end;
-
-
-    procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean);
-      var
-        old_get_para_resulttype : boolean;
-        old_array_constructor : boolean;
-        oldtype     : pdef;
-{$ifdef extdebug}
-        store_count_ref : boolean;
-{$endif def extdebug}
-        {convtyp     : tconverttype;}
-      begin
-         inc(parsing_para_level);
-{$ifdef extdebug}
-         if do_count then
-           begin
-             store_count_ref:=count_ref;
-             count_ref:=true;
-           end;
-{$endif def extdebug}
-         if assigned(p^.right) then
-           begin
-              if defcoll=nil then
-                firstcallparan(p^.right,nil,do_count)
-              else
-                firstcallparan(p^.right,pparaitem(defcoll^.next),do_count);
-              p^.registers32:=p^.right^.registers32;
-              p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.right^.registersmmx;
-{$endif}
-           end;
-         if defcoll=nil then
-           begin
-              old_array_constructor:=allow_array_constructor;
-              old_get_para_resulttype:=get_para_resulttype;
-              get_para_resulttype:=true;
-              allow_array_constructor:=true;
-              firstpass(p^.left);
-              get_para_resulttype:=old_get_para_resulttype;
-              allow_array_constructor:=old_array_constructor;
-              if codegenerror then
-                begin
-                   dec(parsing_para_level);
-                   exit;
-                end;
-              p^.resulttype:=p^.left^.resulttype;
-           end
-         { if we know the routine which is called, then the type }
-         { conversions are inserted                           }
-         else
-           begin
-              { Do we need arrayconstructor -> set conversion, then insert
-                it here before the arrayconstructor node breaks the tree
-                with its conversions of enum->ord }
-              if (p^.left^.treetype=arrayconstructn) and
-                 (defcoll^.paratype.def^.deftype=setdef) then
-                p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
-
-              { set some settings needed for arrayconstructor }
-              if is_array_constructor(p^.left^.resulttype) then
-               begin
-                 if is_array_of_const(defcoll^.paratype.def) then
-                  begin
-                    if assigned(aktcallprocsym) and
-                       (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
-                       (po_external in aktcallprocsym^.definition^.procoptions) then
-                      p^.left^.cargs:=true;
-                    { force variant array }
-                    p^.left^.forcevaria:=true;
-                  end
-                 else
-                  begin
-                    p^.left^.novariaallowed:=true;
-                    p^.left^.constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
-                  end;
-               end;
-
-              if do_count then
-               begin
-                 { not completly proper, but avoids some warnings }
-                 if (defcoll^.paratyp=vs_var) then
-                   set_funcret_is_valid(p^.left);
-
-                 { protected has nothing to do with read/write
-                 if (defcoll^.paratyp=vs_var) then
-                   test_protected(p^.left);
-                 }
-                 { set_varstate(p^.left,defcoll^.paratyp<>vs_var);
-                   must only be done after typeconv PM }
-                 { only process typeconvn and arrayconstructn, else it will
-                   break other trees }
-                 { But this is need to get correct varstate !! PM }
-                 old_array_constructor:=allow_array_constructor;
-                 old_get_para_resulttype:=get_para_resulttype;
-                 allow_array_constructor:=true;
-                 get_para_resulttype:=false;
-                  if (p^.left^.treetype in [arrayconstructn,typeconvn]) then
-                   firstpass(p^.left);
-                 if not assigned(p^.resulttype) then
-                   p^.resulttype:=p^.left^.resulttype;
-                 get_para_resulttype:=old_get_para_resulttype;
-                 allow_array_constructor:=old_array_constructor;
-               end;
-              { check if local proc/func is assigned to procvar }
-              if p^.left^.resulttype^.deftype=procvardef then
-                test_local_to_procvar(pprocvardef(p^.left^.resulttype),defcoll^.paratype.def);
-              { property is not allowed as var parameter }
-              if (defcoll^.paratyp in [vs_out,vs_var]) and
-                 (p^.left^.isproperty) then
-                CGMessagePos(p^.left^.fileinfo,type_e_argument_cant_be_assigned);
-              { generate the high() value tree }
-              if push_high_param(defcoll^.paratype.def) then
-                gen_high_tree(p,is_open_string(defcoll^.paratype.def));
-              if not(is_shortstring(p^.left^.resulttype) and
-                     is_shortstring(defcoll^.paratype.def)) and
-                     (defcoll^.paratype.def^.deftype<>formaldef) then
-                begin
-                   if (defcoll^.paratyp in [vs_var,vs_out]) and
-                   { allows conversion from word to integer and
-                     byte to shortint }
-                     (not(
-                        (p^.left^.resulttype^.deftype=orddef) and
-                        (defcoll^.paratype.def^.deftype=orddef) and
-                        (p^.left^.resulttype^.size=defcoll^.paratype.def^.size)
-                         ) and
-                   { an implicit pointer conversion is allowed }
-                     not(
-                        (p^.left^.resulttype^.deftype=pointerdef) and
-                        (defcoll^.paratype.def^.deftype=pointerdef)
-                         ) and
-                   { child classes can be also passed }
-                     not(
-                        (p^.left^.resulttype^.deftype=objectdef) and
-                        (defcoll^.paratype.def^.deftype=objectdef) and
-                        pobjectdef(p^.left^.resulttype)^.is_related(pobjectdef(defcoll^.paratype.def))
-                        ) and
-                   { passing a single element to a openarray of the same type }
-                     not(
-                        (is_open_array(defcoll^.paratype.def) and
-                        is_equal(parraydef(defcoll^.paratype.def)^.elementtype.def,p^.left^.resulttype))
-                        ) and
-                   { an implicit file conversion is also allowed }
-                   { from a typed file to an untyped one           }
-                     not(
-                        (p^.left^.resulttype^.deftype=filedef) and
-                        (defcoll^.paratype.def^.deftype=filedef) and
-                        (pfiledef(defcoll^.paratype.def)^.filetyp = ft_untyped) and
-                        (pfiledef(p^.left^.resulttype)^.filetyp = ft_typed)
-                         ) and
-                     not(is_equal(p^.left^.resulttype,defcoll^.paratype.def))) then
-                       begin
-                          CGMessagePos2(p^.left^.fileinfo,parser_e_call_by_ref_without_typeconv,
-                            p^.left^.resulttype^.typename,defcoll^.paratype.def^.typename);
-                       end;
-                   { Process open parameters }
-                   if push_high_param(defcoll^.paratype.def) then
-                    begin
-                      { insert type conv but hold the ranges of the array }
-                      oldtype:=p^.left^.resulttype;
-                      p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
-                      firstpass(p^.left);
-                      p^.left^.resulttype:=oldtype;
-                    end
-                   else
-                    begin
-                      p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
-                      firstpass(p^.left);
-                    end;
-                   if codegenerror then
-                     begin
-                        dec(parsing_para_level);
-                        exit;
-                     end;
-                end;
-              { check var strings }
-              if (cs_strict_var_strings in aktlocalswitches) and
-                 is_shortstring(p^.left^.resulttype) and
-                 is_shortstring(defcoll^.paratype.def) and
-                 (defcoll^.paratyp in [vs_out,vs_var]) and
-                 not(is_open_string(defcoll^.paratype.def)) and
-                 not(is_equal(p^.left^.resulttype,defcoll^.paratype.def)) then
-                 begin
-                    aktfilepos:=p^.left^.fileinfo;
-                    CGMessage(type_e_strict_var_string_violation);
-                 end;
-
-              { Variablen for call by reference may not be copied }
-              { into a register }
-              { is this usefull here ? }
-              { this was missing in formal parameter list   }
-              if (defcoll^.paratype.def=pdef(cformaldef)) then
-                begin
-                  if defcoll^.paratyp=vs_var then
-                    begin
-                      if not valid_for_formal_var(p^.left) then
-                        begin
-                           aktfilepos:=p^.left^.fileinfo;
-                           CGMessage(parser_e_illegal_parameter_list);
-                        end;
-                    end;
-                  if defcoll^.paratyp=vs_const then
-                    begin
-                      if not valid_for_formal_const(p^.left) then
-                        begin
-                           aktfilepos:=p^.left^.fileinfo;
-                           CGMessage(parser_e_illegal_parameter_list);
-                        end;
-                    end;
-                end;
-
-              if defcoll^.paratyp in [vs_var,vs_const] then
-                begin
-                   { Causes problems with const ansistrings if also }
-                   { done for vs_const (JM)                         }
-                   if defcoll^.paratyp = vs_var then
-                     set_unique(p^.left);
-                   make_not_regable(p^.left);
-                end;
-
-              { ansistrings out paramaters doesn't need to be  }
-              { unique, they are finalized                     }
-              if defcoll^.paratyp=vs_out then
-                make_not_regable(p^.left);
-
-              if do_count then
-                set_varstate(p^.left,defcoll^.paratyp <> vs_var);
-                { must only be done after typeconv PM }
-              p^.resulttype:=defcoll^.paratype.def;
-           end;
-         if p^.left^.registers32>p^.registers32 then
-           p^.registers32:=p^.left^.registers32;
-         if p^.left^.registersfpu>p^.registersfpu then
-           p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if p^.left^.registersmmx>p^.registersmmx then
-           p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         dec(parsing_para_level);
-{$ifdef extdebug}
-         if do_count then
-           count_ref:=store_count_ref;
-{$endif def extdebug}
-      end;
-
-
-{*****************************************************************************
-                             FirstCallN
-*****************************************************************************}
-
-    procedure firstcalln(var p : ptree);
-      type
-         pprocdefcoll = ^tprocdefcoll;
-         tprocdefcoll = record
-            data      : pprocdef;
-            nextpara  : pparaitem;
-            firstpara : pparaitem;
-            next      : pprocdefcoll;
-         end;
-      var
-         hp,procs,hp2 : pprocdefcoll;
-         pd : pprocdef;
-         oldcallprocsym : pprocsym;
-         def_from,def_to,conv_to : pdef;
-         hpt,pt,inlinecode : ptree;
-         exactmatch,inlined : boolean;
-         paralength,lastpara : longint;
-         lastparatype : pdef;
-         pdc : pparaitem;
-{$ifdef TEST_PROCSYMS}
-         nextprocsym : pprocsym;
-         symt : psymtable;
-{$endif TEST_PROCSYMS}
-
-         { only Dummy }
-         hcvt : tconverttype;
-{$ifdef m68k}
-         regi : tregister;
-{$endif}
-         method_must_be_valid : boolean;
-      label
-        errorexit;
-
-      { check if the resulttype from tree p is equal with def, needed
-        for stringconstn and formaldef }
-      function is_equal(p:ptree;def:pdef) : boolean;
-
-        begin
-           { safety check }
-           if not (assigned(def) or assigned(p^.resulttype)) then
-            begin
-              is_equal:=false;
-              exit;
-            end;
-           { all types can be passed to a formaldef }
-           is_equal:=(def^.deftype=formaldef) or
-             (types.is_equal(p^.resulttype,def))
-           { integer constants are compatible with all integer parameters if
-             the specified value matches the range }
-             or
-             (
-              (p^.left^.treetype=ordconstn) and
-              is_integer(p^.resulttype) and
-              is_integer(def) and
-              (p^.left^.value>=porddef(def)^.low) and
-              (p^.left^.value<=porddef(def)^.high)
-             )
-           { to support ansi/long/wide strings in a proper way }
-           { string and string[10] are assumed as equal }
-           { when searching the correct overloaded procedure   }
-             or
-             (
-              (def^.deftype=stringdef) and (p^.resulttype^.deftype=stringdef) and
-              (pstringdef(def)^.string_typ=pstringdef(p^.resulttype)^.string_typ)
-             )
-             or
-             (
-              (p^.left^.treetype=stringconstn) and
-              (is_ansistring(p^.resulttype) and is_pchar(def))
-             )
-             or
-             (
-              (p^.left^.treetype=ordconstn) and
-              (is_char(p^.resulttype) and (is_shortstring(def) or is_ansistring(def)))
-             )
-           { set can also be a not yet converted array constructor }
-             or
-             (
-              (def^.deftype=setdef) and (p^.resulttype^.deftype=arraydef) and
-              (parraydef(p^.resulttype)^.IsConstructor) and not(parraydef(p^.resulttype)^.IsVariant)
-             )
-           { in tp7 mode proc -> procvar is allowed }
-             or
-             (
-              (m_tp_procvar in aktmodeswitches) and
-              (def^.deftype=procvardef) and (p^.left^.treetype=calln) and
-              (proc_to_procvar_equal(pprocdef(p^.left^.procdefinition),pprocvardef(def)))
-             )
-             ;
-        end;
-
-      function is_in_limit(def_from,def_to : pdef) : boolean;
-
-        begin
-           is_in_limit:=(def_from^.deftype = orddef) and
-                        (def_to^.deftype = orddef) and
-                        (porddef(def_from)^.low>porddef(def_to)^.low) and
-                        (porddef(def_from)^.high<porddef(def_to)^.high);
-        end;
-
-      var
-        is_const : boolean;
-        i : longint;
-        bestord  : porddef;
-      begin
-         { release registers! }
-         { if procdefinition<>nil then we called firstpass already }
-         { it seems to be bad because of the registers }
-         { at least we can avoid the overloaded search !! }
-         procs:=nil;
-         { made this global for disposing !! }
-
-         oldcallprocsym:=aktcallprocsym;
-         aktcallprocsym:=nil;
-
-         inlined:=false;
-         if assigned(p^.procdefinition) and
-            (pocall_inline in p^.procdefinition^.proccalloptions) then
-           begin
-              inlinecode:=p^.right;
-              if assigned(inlinecode) then
-                begin
-                   inlined:=true;
-                   exclude(p^.procdefinition^.proccalloptions,pocall_inline);
-                end;
-              p^.right:=nil;
-           end;
-         if assigned(p^.procdefinition) and
-            (po_containsself in p^.procdefinition^.procoptions) then
-           message(cg_e_cannot_call_message_direct);
-
-         { procedure variable ? }
-         if assigned(p^.right) then
-           begin
-              { procedure does a call }
-              procinfo^.flags:=procinfo^.flags or pi_do_call;
-{$ifndef newcg}
-              { calc the correture value for the register }
-{$ifdef i386}
-              incrementregisterpushed($ff);
-{$endif}
-{$ifdef m68k}
-              for regi:=R_D0 to R_A6 do
-                inc(reg_pushes[regi],t_times*2);
-{$endif}
-{$endif newcg}
-              { calculate the type of the parameters }
-              if assigned(p^.left) then
-                begin
-                   firstcallparan(p^.left,nil,false);
-                   if codegenerror then
-                     goto errorexit;
-                end;
-              firstpass(p^.right);
-              set_varstate(p^.right,true);
-
-              { check the parameters }
-              pdc:=pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first);
-              pt:=p^.left;
-              while assigned(pdc) and assigned(pt) do
-                begin
-                   pt:=pt^.right;
-                   pdc:=pparaitem(pdc^.next);
-                end;
-              if assigned(pt) or assigned(pdc) then
-                begin
-                   if assigned(pt) then
-                     aktfilepos:=pt^.fileinfo;
-                   CGMessage(parser_e_illegal_parameter_list);
-                end;
-              { insert type conversions }
-              if assigned(p^.left) then
-                begin
-                   firstcallparan(p^.left,pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first),true);
-                   if codegenerror then
-                     goto errorexit;
-                end;
-              p^.resulttype:=pprocvardef(p^.right^.resulttype)^.rettype.def;
-
-              { this was missing, leads to a bug below if
-                the procvar is a function }
-              p^.procdefinition:=pabstractprocdef(p^.right^.resulttype);
-           end
-         else
-         { not a procedure variable }
-           begin
-              { determine the type of the parameters }
-              if assigned(p^.left) then
-                begin
-                   firstcallparan(p^.left,nil,false);
-                   if codegenerror then
-                     goto errorexit;
-                end;
-
-              aktcallprocsym:=pprocsym(p^.symtableprocentry);
-              { do we know the procedure to call ? }
-              if not(assigned(p^.procdefinition)) then
-                begin
-{$ifdef TEST_PROCSYMS}
-                 if (p^.unit_specific) or
-                    assigned(p^.methodpointer) then
-                   nextprocsym:=nil
-                 else while not assigned(procs) do
-                  begin
-                     symt:=p^.symtableproc;
-                     srsym:=nil;
-                     while assigned(symt^.next) and not assigned(srsym) do
-                       begin
-                          symt:=symt^.next;
-                          getsymonlyin(symt,actprocsym^.name);
-                          if assigned(srsym) then
-                            if srsym^.typ<>procsym then
-                              begin
-                                 { reject all that is not a procedure }
-                                 srsym:=nil;
-                                 { don't search elsewhere }
-                                 while assigned(symt^.next) do
-                                   symt:=symt^.next;
-                              end;
-                       end;
-                     nextprocsym:=srsym;
-                  end;
-{$endif TEST_PROCSYMS}
-                   { determine length of parameter list }
-                   pt:=p^.left;
-                   paralength:=0;
-                   while assigned(pt) do
-                     begin
-                        inc(paralength);
-                        pt:=pt^.right;
-                     end;
-
-                   { link all procedures which have the same # of parameters }
-                   pd:=aktcallprocsym^.definition;
-                   while assigned(pd) do
-                     begin
-                        { only when the # of parameter are supported by the
-                          procedure }
-                        if (paralength>=pd^.minparacount) and (paralength<=pd^.maxparacount) then
-                          begin
-                             new(hp);
-                             hp^.data:=pd;
-                             hp^.next:=procs;
-                             hp^.firstpara:=pparaitem(pd^.para^.first);
-                             { if not all parameters are given, then skip the
-                               default parameters }
-                             for i:=1 to pd^.maxparacount-paralength do
-                              hp^.firstpara:=pparaitem(hp^.firstpara^.next);
-                             hp^.nextpara:=hp^.firstpara;
-                             procs:=hp;
-                          end;
-                        pd:=pd^.nextoverloaded;
-                     end;
-
-                   { no procedures found? then there is something wrong
-                     with the parameter size }
-                   if not assigned(procs) then
-                    begin
-                      { in tp mode we can try to convert to procvar if
-                        there are no parameters specified }
-                      if not(assigned(p^.left)) and
-                         (m_tp_procvar in aktmodeswitches) then
-                        begin
-                          if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                             (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
-                           hpt:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
-                                 getcopy(p^.methodpointer))
-                          else
-                           hpt:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
-                          disposetree(p);
-                          firstpass(hpt);
-                          p:=hpt;
-                        end
-                      else
-                        begin
-                          if assigned(p^.left) then
-                           aktfilepos:=p^.left^.fileinfo;
-                          CGMessage(parser_e_wrong_parameter_size);
-                          aktcallprocsym^.write_parameter_lists(nil);
-                        end;
-                      goto errorexit;
-                    end;
-
-                { now we can compare parameter after parameter }
-                   pt:=p^.left;
-                   { we start with the last parameter }
-                   lastpara:=paralength+1;
-                   lastparatype:=nil;
-                   while assigned(pt) do
-                     begin
-                        dec(lastpara);
-                        { walk all procedures and determine how this parameter matches and set:
-                           1. pt^.exact_match_found if one parameter has an exact match
-                           2. exactmatch if an equal or exact match is found
-
-                           3. para^.argconvtyp to exact,equal or convertable
-                                (when convertable then also convertlevel is set)
-                           4. pt^.convlevel1found if there is a convertlevel=1
-                           5. pt^.convlevel2found if there is a convertlevel=2
-                        }
-                        exactmatch:=false;
-                        hp:=procs;
-                        while assigned(hp) do
-                          begin
-                             if is_equal(pt,hp^.nextpara^.paratype.def) then
-                               begin
-                                  if hp^.nextpara^.paratype.def=pt^.resulttype then
-                                    begin
-                                       pt^.exact_match_found:=true;
-                                       hp^.nextpara^.argconvtyp:=act_exact;
-                                    end
-                                  else
-                                    hp^.nextpara^.argconvtyp:=act_equal;
-                                  exactmatch:=true;
-                               end
-                             else
-                               begin
-                                 hp^.nextpara^.argconvtyp:=act_convertable;
-                                 hp^.nextpara^.convertlevel:=isconvertable(pt^.resulttype,hp^.nextpara^.paratype.def,
-                                     hcvt,pt^.left^.treetype,false);
-                                 case hp^.nextpara^.convertlevel of
-                                  1 : pt^.convlevel1found:=true;
-                                  2 : pt^.convlevel2found:=true;
-                                 end;
-                               end;
-
-                             hp:=hp^.next;
-                          end;
-
-                        { If there was an exactmatch then delete all convertables }
-                        if exactmatch then
-                          begin
-                            hp:=procs;
-                            procs:=nil;
-                            while assigned(hp) do
-                              begin
-                                 hp2:=hp^.next;
-                                 { keep if not convertable }
-                                 if (hp^.nextpara^.argconvtyp<>act_convertable) then
-                                  begin
-                                    hp^.next:=procs;
-                                    procs:=hp;
-                                  end
-                                 else
-                                  dispose(hp);
-                                 hp:=hp2;
-                              end;
-                          end
-                        else
-                        { No exact match was found, remove all procedures that are
-                          not convertable (convertlevel=0) }
-                          begin
-                            hp:=procs;
-                            procs:=nil;
-                            while assigned(hp) do
-                              begin
-                                 hp2:=hp^.next;
-                                 { keep if not convertable }
-                                 if (hp^.nextpara^.convertlevel<>0) then
-                                  begin
-                                    hp^.next:=procs;
-                                    procs:=hp;
-                                  end
-                                 else
-                                  begin
-                                    { save the type for nice error message }
-                                    lastparatype:=hp^.nextpara^.paratype.def;
-                                    dispose(hp);
-                                  end;
-                                 hp:=hp2;
-                              end;
-                          end;
-                        { update nextpara for all procedures }
-                        hp:=procs;
-                        while assigned(hp) do
-                          begin
-                             hp^.nextpara:=pparaitem(hp^.nextpara^.next);
-                             hp:=hp^.next;
-                          end;
-                        { load next parameter or quit loop if no procs left }
-                        if assigned(procs) then
-                          pt:=pt^.right
-                        else
-                          break;
-                     end;
-
-                 { All parameters are checked, check if there are any
-                   procedures left }
-                   if not assigned(procs) then
-                    begin
-                      { there is an error, must be wrong type, because
-                        wrong size is already checked (PFV) }
-                      if (not assigned(lastparatype)) or
-                         (not assigned(pt)) or
-                         (not assigned(pt^.resulttype)) then
-                        internalerror(39393)
-                      else
-                        begin
-                          aktfilepos:=pt^.fileinfo;
-                          CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
-                            pt^.resulttype^.typename,lastparatype^.typename);
-                        end;
-                      aktcallprocsym^.write_parameter_lists(nil);
-                      goto errorexit;
-                    end;
-
-                   { if there are several choices left then for orddef }
-                   { if a type is totally included in the other }
-                   { we don't fear an overflow ,                       }
-                   { so we can do as if it is an exact match       }
-                   { this will convert integer to longint             }
-                   { rather than to words                             }
-                   { conversion of byte to integer or longint     }
-                   {would still not be solved                     }
-                   if assigned(procs) and assigned(procs^.next) then
-                     begin
-                        hp:=procs;
-                        while assigned(hp) do
-                          begin
-                            hp^.nextpara:=hp^.firstpara;
-                            hp:=hp^.next;
-                          end;
-                        pt:=p^.left;
-                        while assigned(pt) do
-                          begin
-                             { matches a parameter of one procedure exact ? }
-                             exactmatch:=false;
-                             def_from:=pt^.resulttype;
-                             hp:=procs;
-                             while assigned(hp) do
-                               begin
-                                  if not is_equal(pt,hp^.nextpara^.paratype.def) then
-                                    begin
-                                       def_to:=hp^.nextpara^.paratype.def;
-                                       if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and
-                                         (is_in_limit(def_from,def_to) or
-                                         ((hp^.nextpara^.paratyp in [vs_var,vs_out]) and
-                                         (def_from^.size=def_to^.size))) then
-                                         begin
-                                            exactmatch:=true;
-                                            conv_to:=def_to;
-                                         end;
-                                    end;
-                                  hp:=hp^.next;
-                               end;
-
-                             { .... if yes, del all the other procedures }
-                             if exactmatch then
-                               begin
-                                  { the first .... }
-                                  while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.paratype.def)) do
-                                    begin
-                                       hp:=procs^.next;
-                                       dispose(procs);
-                                       procs:=hp;
-                                    end;
-                                  { and the others }
-                                  hp:=procs;
-                                  while (assigned(hp)) and assigned(hp^.next) do
-                                    begin
-                                       if not(is_in_limit(def_from,hp^.next^.nextpara^.paratype.def)) then
-                                         begin
-                                            hp2:=hp^.next^.next;
-                                            dispose(hp^.next);
-                                            hp^.next:=hp2;
-                                         end
-                                       else
-                                         begin
-                                           def_to:=hp^.next^.nextpara^.paratype.def;
-                                           if (conv_to^.size>def_to^.size) or
-                                              ((porddef(conv_to)^.low<porddef(def_to)^.low) and
-                                              (porddef(conv_to)^.high>porddef(def_to)^.high)) then
-                                             begin
-                                                hp2:=procs;
-                                                procs:=hp;
-                                                conv_to:=def_to;
-                                                dispose(hp2);
-                                             end
-                                           else
-                                             hp:=hp^.next;
-                                         end;
-                                    end;
-                               end;
-                             { update nextpara for all procedures }
-                             hp:=procs;
-                             while assigned(hp) do
-                               begin
-                                  hp^.nextpara:=pparaitem(hp^.nextpara^.next);
-                                  hp:=hp^.next;
-                               end;
-                             pt:=pt^.right;
-                          end;
-                     end;
-
-                   { let's try to eliminate equal if there is an exact match
-                     is there }
-                   if assigned(procs) and assigned(procs^.next) then
-                     begin
-                        { reset nextpara for all procs left }
-                        hp:=procs;
-                        while assigned(hp) do
-                         begin
-                           hp^.nextpara:=hp^.firstpara;
-                           hp:=hp^.next;
-                         end;
-
-                        pt:=p^.left;
-                        while assigned(pt) do
-                          begin
-                             if pt^.exact_match_found then
-                               begin
-                                 hp:=procs;
-                                 procs:=nil;
-                                 while assigned(hp) do
-                                   begin
-                                      hp2:=hp^.next;
-                                      { keep the exact matches, dispose the others }
-                                      if (hp^.nextpara^.argconvtyp=act_exact) then
-                                       begin
-                                         hp^.next:=procs;
-                                         procs:=hp;
-                                       end
-                                      else
-                                       dispose(hp);
-                                      hp:=hp2;
-                                   end;
-                               end;
-                             { update nextpara for all procedures }
-                             hp:=procs;
-                             while assigned(hp) do
-                               begin
-                                  hp^.nextpara:=pparaitem(hp^.nextpara^.next);
-                                  hp:=hp^.next;
-                               end;
-                             pt:=pt^.right;
-                          end;
-                     end;
-
-                   { Check if there are integer constant to integer
-                     parameters then choose the best matching integer
-                     parameter and remove the others, this is Delphi
-                     compatible. 1 = byte, 256 = word, etc. }
-                   if assigned(procs) and assigned(procs^.next) then
-                     begin
-                        { reset nextpara for all procs left }
-                        hp:=procs;
-                        while assigned(hp) do
-                         begin
-                           hp^.nextpara:=hp^.firstpara;
-                           hp:=hp^.next;
-                         end;
-
-                        pt:=p^.left;
-                        while assigned(pt) do
-                          begin
-                            bestord:=nil;
-                            if (pt^.left^.treetype=ordconstn) and
-                               is_integer(pt^.resulttype) then
-                             begin
-                               hp:=procs;
-                               while assigned(hp) do
-                                begin
-                                  def_to:=hp^.nextpara^.paratype.def;
-                                  { to be sure, it couldn't be something else,
-                                    also the defs here are all in the range
-                                    so now find the closest range }
-                                  if not is_integer(def_to) then
-                                   internalerror(43297815);
-                                  if (not assigned(bestord)) or
-                                     ((porddef(def_to)^.low>bestord^.low) or
-                                      (porddef(def_to)^.high<bestord^.high)) then
-                                   bestord:=porddef(def_to);
-                                  hp:=hp^.next;
-                                end;
-                             end;
-                            { if a bestmatch is found then remove the other
-                              procs which don't match the bestord }
-                            if assigned(bestord) then
-                             begin
-                               hp:=procs;
-                               procs:=nil;
-                               while assigned(hp) do
-                                begin
-                                  hp2:=hp^.next;
-                                  { keep matching bestord, dispose the others }
-                                  if (porddef(hp^.nextpara^.paratype.def)=bestord) then
-                                   begin
-                                     hp^.next:=procs;
-                                     procs:=hp;
-                                   end
-                                  else
-                                   dispose(hp);
-                                  hp:=hp2;
-                                end;
-                             end;
-
-                            { update nextpara for all procedures }
-                            hp:=procs;
-                            while assigned(hp) do
-                             begin
-                               hp^.nextpara:=pparaitem(hp^.nextpara^.next);
-                               hp:=hp^.next;
-                             end;
-                            pt:=pt^.right;
-                          end;
-                     end;
-
-                   { Check if there are convertlevel 1 and 2 differences
-                     left for the parameters, then discard all convertlevel
-                     2 procedures. The value of convlevelXfound can still
-                     be used, because all convertables are still here or
-                     not }
-                   if assigned(procs) and assigned(procs^.next) then
-                     begin
-                        { reset nextpara for all procs left }
-                        hp:=procs;
-                        while assigned(hp) do
-                         begin
-                           hp^.nextpara:=hp^.firstpara;
-                           hp:=hp^.next;
-                         end;
-
-                        pt:=p^.left;
-                        while assigned(pt) do
-                          begin
-                             if pt^.convlevel1found and pt^.convlevel2found then
-                               begin
-                                 hp:=procs;
-                                 procs:=nil;
-                                 while assigned(hp) do
-                                   begin
-                                      hp2:=hp^.next;
-                                      { keep all not act_convertable and all convertlevels=1 }
-                                      if (hp^.nextpara^.argconvtyp<>act_convertable) or
-                                         (hp^.nextpara^.convertlevel=1) then
-                                       begin
-                                         hp^.next:=procs;
-                                         procs:=hp;
-                                       end
-                                      else
-                                       dispose(hp);
-                                      hp:=hp2;
-                                   end;
-                               end;
-                             { update nextpara for all procedures }
-                             hp:=procs;
-                             while assigned(hp) do
-                               begin
-                                  hp^.nextpara:=pparaitem(hp^.nextpara^.next);
-                                  hp:=hp^.next;
-                               end;
-                             pt:=pt^.right;
-                          end;
-                     end;
-
-                   if not(assigned(procs)) or assigned(procs^.next) then
-                     begin
-                        CGMessage(cg_e_cant_choose_overload_function);
-                        aktcallprocsym^.write_parameter_lists(nil);
-                        goto errorexit;
-                     end;
-{$ifdef TEST_PROCSYMS}
-                   if (procs=nil) and assigned(nextprocsym) then
-                     begin
-                        p^.symtableprocentry:=nextprocsym;
-                        p^.symtableproc:=symt;
-                     end;
-                 end ; { of while assigned(p^.symtableprocentry) do }
-{$endif TEST_PROCSYMS}
-                   if make_ref then
-                     begin
-                        procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@p^.fileinfo));
-                        inc(procs^.data^.refcount);
-                        if procs^.data^.defref=nil then
-                          procs^.data^.defref:=procs^.data^.lastref;
-                     end;
-
-                   p^.procdefinition:=procs^.data;
-                   p^.resulttype:=procs^.data^.rettype.def;
-                   { big error for with statements
-                   p^.symtableproc:=p^.procdefinition^.owner;
-                   but neede for overloaded operators !! }
-                   if p^.symtableproc=nil then
-                     p^.symtableproc:=p^.procdefinition^.owner;
-
-                   p^.location.loc:=LOC_MEM;
-{$ifdef CHAINPROCSYMS}
-                   { object with method read;
-                     call to read(x) will be a usual procedure call }
-                   if assigned(p^.methodpointer) and
-                     (p^.procdefinition^._class=nil) then
-                     begin
-                        { not ok for extended }
-                        case p^.methodpointer^.treetype of
-                           typen,hnewn : fatalerror(no_para_match);
-                        end;
-                        disposetree(p^.methodpointer);
-                        p^.methodpointer:=nil;
-                     end;
-{$endif CHAINPROCSYMS}
-               end; { end of procedure to call determination }
-
-              is_const:=(pocall_internconst in p^.procdefinition^.proccalloptions) and
-                        ((block_type=bt_const) or
-                         (assigned(p^.left) and (p^.left^.left^.treetype in [realconstn,ordconstn])));
-              { handle predefined procedures }
-              if (pocall_internproc in p^.procdefinition^.proccalloptions) or is_const then
-                begin
-                   if assigned(p^.left) then
-                     begin
-                     { settextbuf needs two args }
-                       if assigned(p^.left^.right) then
-                         pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left)
-                       else
-                         begin
-                           pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left^.left);
-                           putnode(p^.left);
-                         end;
-                     end
-                   else
-                     begin
-                       pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,nil);
-                     end;
-                   putnode(p);
-                   firstpass(pt);
-                   p:=pt;
-                   goto errorexit;
-                end
-              else
-                { no intern procedure => we do a call }
-              { calc the correture value for the register }
-              { handle predefined procedures }
-              if (pocall_inline in p^.procdefinition^.proccalloptions) then
-                begin
-                   if assigned(p^.methodpointer) then
-                     CGMessage(cg_e_unable_inline_object_methods);
-                   if assigned(p^.right) and (p^.right^.treetype<>procinlinen) then
-                     CGMessage(cg_e_unable_inline_procvar);
-                   { p^.treetype:=procinlinen; }
-                   if not assigned(p^.right) then
-                     begin
-                        if assigned(pprocdef(p^.procdefinition)^.code) then
-                          inlinecode:=genprocinlinenode(p,ptree(pprocdef(p^.procdefinition)^.code))
-                        else
-                          CGMessage(cg_e_no_code_for_inline_stored);
-                        if assigned(inlinecode) then
-                          begin
-                             { consider it has not inlined if called
-                               again inside the args }
-                             exclude(p^.procdefinition^.proccalloptions,pocall_inline);
-                             firstpass(inlinecode);
-                             inlined:=true;
-                          end;
-                     end;
-                end
-              else
-                procinfo^.flags:=procinfo^.flags or pi_do_call;
-
-              { add needed default parameters }
-              if assigned(procs) and
-                 (paralength<p^.procdefinition^.maxparacount) then
-               begin
-                 { add default parameters, just read back the skipped
-                   paras starting from firstpara^.previous, when not available
-                   (all parameters are default) then start with the last
-                   parameter and read backward (PFV) }
-                 if not assigned(procs^.firstpara) then
-                  pdc:=pparaitem(procs^.data^.para^.last)
-                 else
-                  pdc:=pparaitem(procs^.firstpara^.previous);
-                 while assigned(pdc) do
-                  begin
-                    if not assigned(pdc^.defaultvalue) then
-                     internalerror(751349858);
-                    p^.left:=gencallparanode(genconstsymtree(pconstsym(pdc^.defaultvalue)),p^.left);
-                    pdc:=pparaitem(pdc^.previous);
-                  end;
-               end;
-
-              { work trough all parameters to insert the type conversions }
-              if assigned(p^.left) then
-                begin
-                   firstcallparan(p^.left,pparaitem(p^.procdefinition^.para^.first),true);
-                end;
-{$ifndef newcg}
-{$ifdef i386}
-              incrementregisterpushed(pprocdef(p^.procdefinition)^.usedregisters);
-{$endif}
-{$ifdef m68k}
-             for regi:=R_D0 to R_A6 do
-               begin
-                  if (pprocdef(p^.procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
-                    inc(reg_pushes[regi],t_times*2);
-               end;
-{$endif}
-{$endif newcg}
-           end;
-         { ensure that the result type is set }
-         p^.resulttype:=p^.procdefinition^.rettype.def;
-         { get a register for the return value }
-         if (p^.resulttype<>pdef(voiddef)) then
-           begin
-              if (p^.procdefinition^.proctypeoption=potype_constructor) then
-                begin
-                   { extra handling of classes }
-                   { p^.methodpointer should be assigned! }
-                   if assigned(p^.methodpointer) and assigned(p^.methodpointer^.resulttype) and
-                     (p^.methodpointer^.resulttype^.deftype=classrefdef) then
-                     begin
-                        p^.location.loc:=LOC_REGISTER;
-                        p^.registers32:=1;
-                        { the result type depends on the classref }
-                        p^.resulttype:=pclassrefdef(p^.methodpointer^.resulttype)^.pointertype.def;
-                     end
-                  { a object constructor returns the result with the flags }
-                   else
-                     p^.location.loc:=LOC_FLAGS;
-                end
-              else
-                begin
-{$ifdef SUPPORT_MMX}
-                   if (cs_mmx in aktlocalswitches) and
-                     is_mmx_able_array(p^.resulttype) then
-                     begin
-                        p^.location.loc:=LOC_MMXREGISTER;
-                        p^.registersmmx:=1;
-                     end
-                   else
-{$endif SUPPORT_MMX}
-                   if ret_in_acc(p^.resulttype) then
-                     begin
-                        p^.location.loc:=LOC_REGISTER;
-                        if is_64bitint(p^.resulttype) then
-                          p^.registers32:=2
-                        else
-                          p^.registers32:=1;
-
-                        { wide- and ansistrings are returned in EAX    }
-                        { but they are imm. moved to a memory location }
-                        if is_widestring(p^.resulttype) or
-                          is_ansistring(p^.resulttype) then
-                          begin
-                             p^.location.loc:=LOC_MEM;
-                             { this is wrong we still need one register  PM
-                             p^.registers32:=0; }
-                             { we use ansistrings so no fast exit here }
-                             procinfo^.no_fast_exit:=true;
-                             p^.registers32:=1;
-                          end;
-                     end
-                   else if (p^.resulttype^.deftype=floatdef) then
-                     begin
-                        p^.location.loc:=LOC_FPU;
-                        p^.registersfpu:=1;
-                     end
-                   else
-                     p^.location.loc:=LOC_MEM;
-                end;
-           end;
-         { a fpu can be used in any procedure !! }
-         p^.registersfpu:=p^.procdefinition^.fpu_used;
-         { if this is a call to a method calc the registers }
-         if (p^.methodpointer<>nil) then
-           begin
-              case p^.methodpointer^.treetype of
-                { but only, if this is not a supporting node }
-                typen: ;
-                { we need one register for new return value PM }
-                hnewn : if p^.registers32=0 then
-                          p^.registers32:=1;
-                else
-                  begin
-                     if (p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
-                        assigned(p^.symtable) and (p^.symtable^.symtabletype=withsymtable) and
-                        not pwithsymtable(p^.symtable)^.direct_with then
-                       begin
-                          CGmessage(cg_e_cannot_call_cons_dest_inside_with);
-                       end; { Is accepted by Delphi !! }
-                     { this is not a good reason to accept it in FPC if we produce
-                       wrong code for it !!! (PM) }
-
-                     { R.Assign is not a constructor !!! }
-                     { but for R^.Assign, R must be valid !! }
-                     if (p^.procdefinition^.proctypeoption=potype_constructor) or
-                        ((p^.methodpointer^.treetype=loadn) and
-                        (not(oo_has_virtual in pobjectdef(p^.methodpointer^.resulttype)^.objectoptions))) then
-                       method_must_be_valid:=false
-                     else
-                       method_must_be_valid:=true;
-                     firstpass(p^.methodpointer);
-                     set_varstate(p^.methodpointer,method_must_be_valid);
-                     { The object is already used ven if it is called once }
-                     if (p^.methodpointer^.treetype=loadn) and
-                        (p^.methodpointer^.symtableentry^.typ=varsym) then
-                       pvarsym(p^.methodpointer^.symtableentry)^.varstate:=vs_used;
-
-                     p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu);
-                     p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32);
-{$ifdef SUPPORT_MMX}
-                     p^.registersmmx:=max(p^.methodpointer^.registersmmx,p^.registersmmx);
-{$endif SUPPORT_MMX}
-                  end;
-              end;
-           end;
-
-         if inlined then
-           p^.right:=inlinecode;
-         { determine the registers of the procedure variable }
-         { is this OK for inlined procs also ?? (PM)     }
-         if assigned(p^.right) then
-           begin
-              p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu);
-              p^.registers32:=max(p^.right^.registers32,p^.registers32);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.right^.registersmmx,p^.registersmmx);
-{$endif SUPPORT_MMX}
-           end;
-         { determine the registers of the procedure }
-         if assigned(p^.left) then
-           begin
-              p^.registersfpu:=max(p^.left^.registersfpu,p^.registersfpu);
-              p^.registers32:=max(p^.left^.registers32,p^.registers32);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.left^.registersmmx,p^.registersmmx);
-{$endif SUPPORT_MMX}
-           end;
-      errorexit:
-         { Reset some settings back }
-         if assigned(procs) then
-           dispose(procs);
-         if inlined then
-           include(p^.procdefinition^.proccalloptions,pocall_inline);
-         aktcallprocsym:=oldcallprocsym;
-      end;
-
-
-{*****************************************************************************
-                             FirstProcInlineN
-*****************************************************************************}
-
-    procedure firstprocinline(var p : ptree);
-      begin
-        { left contains the code in tree form }
-        { but it has already been firstpassed }
-        { so firstpass(p^.left); does not seem required }
-        { might be required later if we change the arg handling !! }
-      end;
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.10  2000/09/24 21:19:52  peter
-    * delphi compile fixes
-
-  Revision 1.9  2000/08/27 16:11:54  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.8  2000/08/15 03:43:24  peter
-    * integer constant -> integer para enhanced to search the best matching
-      procedure, just like delphi does (merged)
-
-  Revision 1.7  2000/08/13 14:53:32  peter
-    * integer constant is equal with all integer type arguments (merged)
-
-  Revision 1.6  2000/08/13 12:54:56  peter
-    * class member decl wrong then no other error after it
-    * -vb has now also line numbering
-    * -vb is also used for interface/implementation different decls and
-      doesn't list the current function (merged)
-
-  Revision 1.5  2000/08/08 19:23:28  peter
-    * crash fix for default para when all parameters were omitted
-
-  Revision 1.4  2000/08/06 19:39:28  peter
-    * default parameters working !
-
-  Revision 1.3  2000/07/13 12:08:28  michael
-  + patched to 1.1.0 with former 1.09patch from peter
-
-  Revision 1.2  2000/07/13 11:32:51  michael
-  + removed logs
-
-}

compiler/old/tccnv.pas

@@ -1,1076 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for type converting nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tccnv;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure arrayconstructor_to_set(var p:ptree);
-
-    procedure firsttypeconv(var p : ptree);
-    procedure firstas(var p : ptree);
-    procedure firstis(var p : ptree);
-
-
-implementation
-
-   uses
-      globtype,systems,tokens,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-{$ifdef newcg}
-      cgbase,
-{$else newcg}
-      hcodegen,
-{$endif newcg}
-      htypechk,pass_1,cpubase;
-
-
-{*****************************************************************************
-                    Array constructor to Set Conversion
-*****************************************************************************}
-
-    procedure arrayconstructor_to_set(var p:ptree);
-      var
-        constp,
-        buildp,
-        p2,p3,p4    : ptree;
-        pd        : pdef;
-        constset    : pconstset;
-        constsetlo,
-        constsethi  : longint;
-
-        procedure update_constsethi(p:pdef);
-        begin
-          if ((p^.deftype=orddef) and
-             (porddef(p)^.high>=constsethi)) then
-            begin
-               constsethi:=porddef(p)^.high;
-               if pd=nil then
-                 begin
-                    if (constsethi>255) or
-                      (porddef(p)^.low<0) then
-                      pd:=u8bitdef
-                    else
-                      pd:=p;
-                 end;
-               if constsethi>255 then
-                 constsethi:=255;
-            end
-          else if ((p^.deftype=enumdef) and
-            (penumdef(p)^.max>=constsethi)) then
-            begin
-               if pd=nil then
-                 pd:=p;
-               constsethi:=penumdef(p)^.max;
-            end;
-        end;
-
-        procedure do_set(pos : longint);
-        var
-          mask,l : longint;
-        begin
-          if (pos>255) or (pos<0) then
-           Message(parser_e_illegal_set_expr);
-          if pos>constsethi then
-           constsethi:=pos;
-          if pos<constsetlo then
-           constsetlo:=pos;
-          l:=pos shr 3;
-          mask:=1 shl (pos mod 8);
-          { do we allow the same twice }
-          if (constset^[l] and mask)<>0 then
-           Message(parser_e_illegal_set_expr);
-          constset^[l]:=constset^[l] or mask;
-        end;
-
-      var
-        l : longint;
-        lr,hr : longint;
-
-      begin
-        new(constset);
-        FillChar(constset^,sizeof(constset^),0);
-        pd:=nil;
-        constsetlo:=0;
-        constsethi:=0;
-        constp:=gensinglenode(setconstn,nil);
-        constp^.value_set:=constset;
-        buildp:=constp;
-        if assigned(p^.left) then
-         begin
-           while assigned(p) do
-            begin
-              p4:=nil; { will contain the tree to create the set }
-            { split a range into p2 and p3 }
-              if p^.left^.treetype=arrayconstructrangen then
-               begin
-                 p2:=p^.left^.left;
-                 p3:=p^.left^.right;
-               { node is not used anymore }
-                 putnode(p^.left);
-               end
-              else
-               begin
-                 p2:=p^.left;
-                 p3:=nil;
-               end;
-              firstpass(p2);
-              if assigned(p3) then
-               firstpass(p3);
-              if codegenerror then
-               break;
-              case p2^.resulttype^.deftype of
-                 enumdef,
-                 orddef:
-                   begin
-                      getrange(p2^.resulttype,lr,hr);
-                      if assigned(p3) then
-                       begin
-                         { this isn't good, you'll get problems with
-                           type t010 = 0..10;
-                                ts = set of t010;
-                           var  s : ts;b : t010
-                           begin  s:=[1,2,b]; end.
-                         if is_integer(p3^.resulttype) then
-                          begin
-                            p3:=gentypeconvnode(p3,u8bitdef);
-                            firstpass(p3);
-                          end;
-                         }
-
-                         if assigned(pd) and not(is_equal(pd,p3^.resulttype)) then
-                           begin
-                              aktfilepos:=p3^.fileinfo;
-                              CGMessage(type_e_typeconflict_in_set);
-                           end
-                         else
-                           begin
-                             if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then
-                              begin
-                                 if not(is_integer(p3^.resulttype)) then
-                                   pd:=p3^.resulttype
-                                 else
-                                   begin
-                                      p3:=gentypeconvnode(p3,u8bitdef);
-                                      p2:=gentypeconvnode(p2,u8bitdef);
-                                      firstpass(p2);
-                                      firstpass(p3);
-                                   end;
-
-                                for l:=p2^.value to p3^.value do
-                                  do_set(l);
-                                disposetree(p3);
-                                disposetree(p2);
-                              end
-                             else
-                              begin
-                                update_constsethi(p2^.resulttype);
-                                p2:=gentypeconvnode(p2,pd);
-                                firstpass(p2);
-
-                                update_constsethi(p3^.resulttype);
-                                p3:=gentypeconvnode(p3,pd);
-                                firstpass(p3);
-
-
-                                if assigned(pd) then
-                                  p3:=gentypeconvnode(p3,pd)
-                                else
-                                  p3:=gentypeconvnode(p3,u8bitdef);
-                                firstpass(p3);
-                                p4:=gennode(setelementn,p2,p3);
-                              end;
-                           end;
-                       end
-                      else
-                       begin
-                      { Single value }
-                         if p2^.treetype=ordconstn then
-                          begin
-                            if not(is_integer(p2^.resulttype)) then
-                              update_constsethi(p2^.resulttype)
-                            else
-                              begin
-                                 p2:=gentypeconvnode(p2,u8bitdef);
-                                 firstpass(p2);
-                              end;
-
-                            do_set(p2^.value);
-                            disposetree(p2);
-                          end
-                         else
-                          begin
-                            update_constsethi(p2^.resulttype);
-
-                            if assigned(pd) then
-                              p2:=gentypeconvnode(p2,pd)
-                            else
-                              p2:=gentypeconvnode(p2,u8bitdef);
-                            firstpass(p2);
-
-                            p4:=gennode(setelementn,p2,nil);
-                          end;
-                       end;
-                    end;
-          stringdef : begin
-                        { if we've already set elements which are constants }
-                        { throw an error                                    }
-                        if ((pd=nil) and assigned(buildp)) or
-                          not(is_equal(pd,cchardef)) then
-                          CGMessage(type_e_typeconflict_in_set)
-                        else
-                         for l:=1 to length(pstring(p2^.value_str)^) do
-                          do_set(ord(pstring(p2^.value_str)^[l]));
-                        if pd=nil then
-                         pd:=cchardef;
-                        disposetree(p2);
-                      end;
-              else
-               CGMessage(type_e_ordinal_expr_expected);
-              end;
-            { insert the set creation tree }
-              if assigned(p4) then
-               buildp:=gennode(addn,buildp,p4);
-            { load next and dispose current node }
-              p2:=p;
-              p:=p^.right;
-              putnode(p2);
-            end;
-          if (pd=nil) then
-            begin
-               pd:=u8bitdef;
-               constsethi:=255;
-            end;
-         end
-        else
-         begin
-         { empty set [], only remove node }
-           putnode(p);
-         end;
-      { set the initial set type }
-        constp^.resulttype:=new(psetdef,init(pd,constsethi));
-      { set the new tree }
-        p:=buildp;
-      end;
-
-
-{*****************************************************************************
-                             FirstTypeConv
-*****************************************************************************}
-
-    type
-       tfirstconvproc = procedure(var p : ptree);
-
-    procedure first_int_to_int(var p : ptree);
-      begin
-        if (p^.left^.location.loc<>LOC_REGISTER) and
-           (p^.resulttype^.size>p^.left^.resulttype^.size) then
-           p^.location.loc:=LOC_REGISTER;
-        if is_64bitint(p^.resulttype) then
-          p^.registers32:=max(p^.registers32,2)
-        else
-          p^.registers32:=max(p^.registers32,1);
-      end;
-
-
-    procedure first_cstring_to_pchar(var p : ptree);
-      begin
-         p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_string_to_chararray(var p : ptree);
-      begin
-         p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_string_to_string(var p : ptree);
-      var
-        hp : ptree;
-      begin
-         if pstringdef(p^.resulttype)^.string_typ<>
-            pstringdef(p^.left^.resulttype)^.string_typ then
-           begin
-              if p^.left^.treetype=stringconstn then
-                begin
-                   p^.left^.stringtype:=pstringdef(p^.resulttype)^.string_typ;
-                   p^.left^.resulttype:=p^.resulttype;
-                   { remove typeconv node }
-                   hp:=p;
-                   p:=p^.left;
-                   putnode(hp);
-                   exit;
-                end
-              else
-                procinfo^.flags:=procinfo^.flags or pi_do_call;
-           end;
-         { for simplicity lets first keep all ansistrings
-           as LOC_MEM, could also become LOC_REGISTER }
-         if pstringdef(p^.resulttype)^.string_typ in [st_ansistring,st_widestring] then
-           { we may use ansistrings so no fast exit here }
-           procinfo^.no_fast_exit:=true;
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-    procedure first_char_to_string(var p : ptree);
-      var
-         hp : ptree;
-      begin
-         if p^.left^.treetype=ordconstn then
-           begin
-              hp:=genstringconstnode(chr(p^.left^.value),st_default);
-              hp^.stringtype:=pstringdef(p^.resulttype)^.string_typ;
-              firstpass(hp);
-              disposetree(p);
-              p:=hp;
-           end
-         else
-           p^.location.loc:=LOC_MEM;
-      end;
-
-
-    procedure first_nothing(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-    procedure first_array_to_pointer(var p : ptree);
-      begin
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_int_to_real(var p : ptree);
-      var
-        t : ptree;
-      begin
-        if p^.left^.treetype=ordconstn then
-         begin
-           t:=genrealconstnode(p^.left^.value,pfloatdef(p^.resulttype));
-           firstpass(t);
-           disposetree(p);
-           p:=t;
-           exit;
-         end;
-        if p^.registersfpu<1 then
-         p^.registersfpu:=1;
-        p^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure first_int_to_fix(var p : ptree);
-      var
-        t : ptree;
-      begin
-        if p^.left^.treetype=ordconstn then
-         begin
-           t:=genfixconstnode(p^.left^.value shl 16,p^.resulttype);
-           firstpass(t);
-           disposetree(p);
-           p:=t;
-           exit;
-         end;
-        if p^.registers32<1 then
-         p^.registers32:=1;
-        p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_real_to_fix(var p : ptree);
-      var
-        t : ptree;
-      begin
-        if p^.left^.treetype=fixconstn then
-         begin
-           t:=genfixconstnode(round(p^.left^.value_real*65536),p^.resulttype);
-           firstpass(t);
-           disposetree(p);
-           p:=t;
-           exit;
-         end;
-        { at least one fpu and int register needed }
-        if p^.registers32<1 then
-          p^.registers32:=1;
-        if p^.registersfpu<1 then
-          p^.registersfpu:=1;
-        p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_fix_to_real(var p : ptree);
-      var
-        t : ptree;
-      begin
-        if p^.left^.treetype=fixconstn then
-          begin
-            t:=genrealconstnode(round(p^.left^.value_fix/65536.0),p^.resulttype);
-            firstpass(t);
-            disposetree(p);
-            p:=t;
-            exit;
-          end;
-        if p^.registersfpu<1 then
-          p^.registersfpu:=1;
-        p^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure first_real_to_real(var p : ptree);
-      var
-        t : ptree;
-      begin
-         if p^.left^.treetype=realconstn then
-           begin
-             t:=genrealconstnode(p^.left^.value_real,p^.resulttype);
-             firstpass(t);
-             disposetree(p);
-             p:=t;
-             exit;
-           end;
-        { comp isn't a floating type }
-{$ifdef i386}
-         if (pfloatdef(p^.resulttype)^.typ=s64comp) and
-            (pfloatdef(p^.left^.resulttype)^.typ<>s64comp) and
-            not (p^.explizit) then
-           CGMessage(type_w_convert_real_2_comp);
-{$endif}
-         if p^.registersfpu<1 then
-           p^.registersfpu:=1;
-         p^.location.loc:=LOC_FPU;
-      end;
-
-
-    procedure first_pointer_to_array(var p : ptree);
-      begin
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         p^.location.loc:=LOC_REFERENCE;
-      end;
-
-
-    procedure first_chararray_to_string(var p : ptree);
-      begin
-         { the only important information is the location of the }
-         { result                                               }
-         { other stuff is done by firsttypeconv           }
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-    procedure first_cchar_to_pchar(var p : ptree);
-      begin
-         p^.left:=gentypeconvnode(p^.left,cshortstringdef);
-         { convert constant char to constant string }
-         firstpass(p^.left);
-         { evalute tree }
-         firstpass(p);
-      end;
-
-
-    procedure first_bool_to_int(var p : ptree);
-      begin
-         { byte(boolean) or word(wordbool) or longint(longbool) must
-         be accepted for var parameters }
-         if (p^.explizit) and
-            (p^.left^.resulttype^.size=p^.resulttype^.size) and
-            (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-           exit;
-         p^.location.loc:=LOC_REGISTER;
-         if p^.registers32<1 then
-           p^.registers32:=1;
-      end;
-
-
-    procedure first_int_to_bool(var p : ptree);
-      begin
-         { byte(boolean) or word(wordbool) or longint(longbool) must
-         be accepted for var parameters }
-         if (p^.explizit) and
-            (p^.left^.resulttype^.size=p^.resulttype^.size) and
-            (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-           exit;
-         p^.location.loc:=LOC_REGISTER;
-         { need if bool to bool !!
-           not very nice !!
-         p^.left:=gentypeconvnode(p^.left,s32bitdef);
-         p^.left^.explizit:=true;
-         firstpass(p^.left);  }
-         if p^.registers32<1 then
-           p^.registers32:=1;
-      end;
-
-
-    procedure first_bool_to_bool(var p : ptree);
-      begin
-         p^.location.loc:=LOC_REGISTER;
-         if p^.registers32<1 then
-           p^.registers32:=1;
-      end;
-
-
-    procedure first_proc_to_procvar(var p : ptree);
-      begin
-         { hmmm, I'am not sure if that is necessary (FK) }
-         firstpass(p^.left);
-         if codegenerror then
-           exit;
-
-         if (p^.left^.location.loc<>LOC_REFERENCE) then
-           CGMessage(cg_e_illegal_expression);
-
-         p^.registers32:=p^.left^.registers32;
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-    procedure first_load_smallset(var p : ptree);
-      begin
-      end;
-
-
-    procedure first_cord_to_pointer(var p : ptree);
-      var
-        t : ptree;
-      begin
-        if p^.left^.treetype=ordconstn then
-          begin
-            t:=genpointerconstnode(p^.left^.value,p^.resulttype);
-            firstpass(t);
-            disposetree(p);
-            p:=t;
-            exit;
-          end
-        else
-          internalerror(432472389);
-      end;
-
-
-    procedure first_pchar_to_string(var p : ptree);
-      begin
-         p^.location.loc:=LOC_REFERENCE;
-      end;
-
-
-    procedure first_ansistring_to_pchar(var p : ptree);
-      begin
-         p^.location.loc:=LOC_REGISTER;
-         if p^.registers32<1 then
-           p^.registers32:=1;
-      end;
-
-
-    procedure first_arrayconstructor_to_set(var p:ptree);
-      var
-        hp : ptree;
-      begin
-        if p^.left^.treetype<>arrayconstructn then
-         internalerror(5546);
-      { remove typeconv node }
-        hp:=p;
-        p:=p^.left;
-        putnode(hp);
-      { create a set constructor tree }
-        arrayconstructor_to_set(p);
-      { now firstpass the set }
-        firstpass(p);
-      end;
-
-
-  procedure firsttypeconv(var p : ptree);
-    var
-      hp : ptree;
-      aprocdef : pprocdef;
-    const
-       firstconvert : array[tconverttype] of tfirstconvproc = (
-         first_nothing, {equal}
-         first_nothing, {not_possible}
-         first_string_to_string,
-         first_char_to_string,
-         first_pchar_to_string,
-         first_cchar_to_pchar,
-         first_cstring_to_pchar,
-         first_ansistring_to_pchar,
-         first_string_to_chararray,
-         first_chararray_to_string,
-         first_array_to_pointer,
-         first_pointer_to_array,
-         first_int_to_int,
-         first_int_to_bool,
-         first_bool_to_bool,
-         first_bool_to_int,
-         first_real_to_real,
-         first_int_to_real,
-         first_int_to_fix,
-         first_real_to_fix,
-         first_fix_to_real,
-         first_proc_to_procvar,
-         first_arrayconstructor_to_set,
-         first_load_smallset,
-         first_cord_to_pointer
-       );
-     begin
-       aprocdef:=nil;
-       { if explicite type cast, then run firstpass }
-       if (p^.explizit) or not assigned(p^.left^.resulttype) then
-         firstpass(p^.left);
-       if (p^.left^.treetype=typen) and (p^.left^.resulttype=generrordef) then
-         begin
-            codegenerror:=true;
-            Message(parser_e_no_type_not_allowed_here);
-         end;
-       if codegenerror then
-         begin
-           p^.resulttype:=generrordef;
-           exit;
-         end;
-
-       if not assigned(p^.left^.resulttype) then
-        begin
-          codegenerror:=true;
-          internalerror(52349);
-          exit;
-        end;
-
-       { load the value_str from the left part }
-       p^.registers32:=p^.left^.registers32;
-       p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-       p^.registersmmx:=p^.left^.registersmmx;
-{$endif}
-       set_location(p^.location,p^.left^.location);
-
-       { remove obsolete type conversions }
-       if is_equal(p^.left^.resulttype,p^.resulttype) then
-         begin
-         { becuase is_equal only checks the basetype for sets we need to
-           check here if we are loading a smallset into a normalset }
-           if (p^.resulttype^.deftype=setdef) and
-              (p^.left^.resulttype^.deftype=setdef) and
-              (psetdef(p^.resulttype)^.settype<>smallset) and
-              (psetdef(p^.left^.resulttype)^.settype=smallset) then
-            begin
-            { try to define the set as a normalset if it's a constant set }
-              if p^.left^.treetype=setconstn then
-               begin
-                 p^.resulttype:=p^.left^.resulttype;
-                 psetdef(p^.resulttype)^.settype:=normset
-               end
-              else
-               p^.convtyp:=tc_load_smallset;
-              exit;
-            end
-           else
-            begin
-              hp:=p;
-              p:=p^.left;
-              p^.resulttype:=hp^.resulttype;
-              putnode(hp);
-              exit;
-            end;
-         end;
-       aprocdef:=assignment_overloaded(p^.left^.resulttype,p^.resulttype);
-       if assigned(aprocdef) then
-         begin
-            procinfo^.flags:=procinfo^.flags or pi_do_call;
-            hp:=gencallnode(overloaded_operators[_assignment],nil);
-            { tell explicitly which def we must use !! (PM) }
-            hp^.procdefinition:=aprocdef;
-            hp^.left:=gencallparanode(p^.left,nil);
-            putnode(p);
-            p:=hp;
-            firstpass(p);
-            exit;
-         end;
-
-       if isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype,p^.explizit)=0 then
-         begin
-           {Procedures have a resulttype of voiddef and functions of their
-           own resulttype. They will therefore always be incompatible with
-           a procvar. Because isconvertable cannot check for procedures we
-           use an extra check for them.}
-           if (m_tp_procvar in aktmodeswitches) then
-            begin
-              if (p^.resulttype^.deftype=procvardef) and
-                 (is_procsym_load(p^.left) or is_procsym_call(p^.left)) then
-               begin
-                 if is_procsym_call(p^.left) then
-                  begin
-                    {if p^.left^.right=nil then
-                     begin}
-                       if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable){ and
-                          (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) }then
-                        hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc,
-                              getcopy(p^.left^.methodpointer))
-                       else
-                        hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
-                       disposetree(p^.left);
-                       firstpass(hp);
-                       p^.left:=hp;
-                       aprocdef:=pprocdef(p^.left^.resulttype);
-                   (*  end
-                    else
-                     begin
-                       p^.left^.right^.treetype:=loadn;
-                       p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
-                       P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
-                       hp:=p^.left^.right;
-                       putnode(p^.left);
-                       p^.left:=hp;
-                       { should we do that ? }
-                       firstpass(p^.left);
-                       if not is_equal(p^.left^.resulttype,p^.resulttype) then
-                        begin
-                          CGMessage(type_e_mismatch);
-                          exit;
-                        end
-                       else
-                        begin
-                          hp:=p;
-                          p:=p^.left;
-                          p^.resulttype:=hp^.resulttype;
-                          putnode(hp);
-                          exit;
-                        end;
-                     end; *)
-                  end
-                 else
-                  begin
-                    if (p^.left^.treetype<>addrn) then
-                      aprocdef:=pprocsym(p^.left^.symtableentry)^.definition;
-                  end;
-                 p^.convtyp:=tc_proc_2_procvar;
-                 { Now check if the procedure we are going to assign to
-                   the procvar,  is compatible with the procvar's type }
-                 if assigned(aprocdef) then
-                  begin
-                    if not proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then
-                     CGMessage2(type_e_incompatible_types,aprocdef^.typename,p^.resulttype^.typename);
-                    firstconvert[p^.convtyp](p);
-                  end
-                 else
-                  CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                 exit;
-               end;
-            end;
-           if p^.explizit then
-            begin
-              { check if the result could be in a register }
-              if not(p^.resulttype^.is_intregable) and
-                not(p^.resulttype^.is_fpuregable) then
-                make_not_regable(p^.left);
-              { boolean to byte are special because the
-                location can be different }
-
-              if is_integer(p^.resulttype) and
-                 is_boolean(p^.left^.resulttype) then
-               begin
-                  p^.convtyp:=tc_bool_2_int;
-                  firstconvert[p^.convtyp](p);
-                  exit;
-               end;
-              { ansistring to pchar }
-              if is_pchar(p^.resulttype) and
-                 is_ansistring(p^.left^.resulttype) then
-               begin
-                 p^.convtyp:=tc_ansistring_2_pchar;
-                 firstconvert[p^.convtyp](p);
-                 exit;
-               end;
-              { do common tc_equal cast }
-              p^.convtyp:=tc_equal;
-
-              { enum to ordinal will always be s32bit }
-              if (p^.left^.resulttype^.deftype=enumdef) and
-                 is_ordinal(p^.resulttype) then
-               begin
-                 if p^.left^.treetype=ordconstn then
-                  begin
-                    hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                    disposetree(p);
-                    firstpass(hp);
-                    p:=hp;
-                    exit;
-                  end
-                 else
-                  begin
-                    if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
-                      CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                  end;
-               end
-
-              { ordinal to enumeration }
-              else
-               if (p^.resulttype^.deftype=enumdef) and
-                  is_ordinal(p^.left^.resulttype) then
-                begin
-                  if p^.left^.treetype=ordconstn then
-                   begin
-                     hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                     disposetree(p);
-                     firstpass(hp);
-                     p:=hp;
-                     exit;
-                   end
-                  else
-                   begin
-                     if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then
-                       CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                   end;
-                end
-
-              { nil to ordinal node }
-              else if is_ordinal(p^.resulttype) and
-                (p^.left^.treetype=niln) then
-                begin
-                   hp:=genordinalconstnode(0,p^.resulttype);
-                   firstpass(hp);
-                   disposetree(p);
-                   p:=hp;
-                   exit;
-                end
-
-              {Are we typecasting an ordconst to a char?}
-              else
-                if is_char(p^.resulttype) and
-                   is_ordinal(p^.left^.resulttype) then
-                 begin
-                   if p^.left^.treetype=ordconstn then
-                    begin
-                      hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                      firstpass(hp);
-                      disposetree(p);
-                      p:=hp;
-                      exit;
-                    end
-                   else
-                    begin
-                      if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then
-                        CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                    end;
-                 end
-
-              { Are we char to ordinal }
-              else
-                if is_char(p^.left^.resulttype) and
-                   is_ordinal(p^.resulttype) then
-                 begin
-                   if p^.left^.treetype=ordconstn then
-                    begin
-                      hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-                      firstpass(hp);
-                      disposetree(p);
-                      p:=hp;
-                      exit;
-                    end
-                   else
-                    begin
-                      if IsConvertable(u8bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
-                        CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-                    end;
-                 end
-
-               { only if the same size or formal def }
-               { why do we allow typecasting of voiddef ?? (PM) }
-               else
-                begin
-                  if not(
-                     (p^.left^.resulttype^.deftype=formaldef) or
-                     (p^.left^.resulttype^.size=p^.resulttype^.size) or
-                     (is_equal(p^.left^.resulttype,voiddef)  and
-                     (p^.left^.treetype=derefn))
-                     ) then
-                    CGMessage(cg_e_illegal_type_conversion);
-                  if ((p^.left^.resulttype^.deftype=orddef) and
-                      (p^.resulttype^.deftype=pointerdef)) or
-                      ((p^.resulttype^.deftype=orddef) and
-                       (p^.left^.resulttype^.deftype=pointerdef))
-                       {$ifdef extdebug}and (p^.firstpasscount=0){$endif} then
-                    CGMessage(cg_d_pointer_to_longint_conv_not_portable);
-                end;
-
-               { the conversion into a strutured type is only }
-               { possible, if the source is no register    }
-               if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or
-                   ((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.is_class))
-                  ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) { and
-                   it also works if the assignment is overloaded
-                   YES but this code is not executed if assignment is overloaded (PM)
-                  not assigned(assignment_overloaded(p^.left^.resulttype,p^.resulttype))} then
-                 CGMessage(cg_e_illegal_type_conversion);
-            end
-           else
-            CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
-         end;
-
-       { tp7 procvar support, when right is not a procvardef and we got a
-         loadn of a procvar then convert to a calln, the check for the
-         result is already done in is_convertible, also no conflict with
-         @procvar is here because that has an extra addrn }
-         if (m_tp_procvar in aktmodeswitches) and
-            (p^.resulttype^.deftype<>procvardef) and
-            (p^.left^.resulttype^.deftype=procvardef) and
-            (p^.left^.treetype=loadn) then
-          begin
-            hp:=gencallnode(nil,nil);
-            hp^.right:=p^.left;
-            firstpass(hp);
-            p^.left:=hp;
-          end;
-
-
-        { ordinal contants can be directly converted }
-        { but not int64/qword                        }
-        if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) and
-          not(is_64bitint(p^.resulttype)) then
-          begin
-             { range checking is done in genordinalconstnode (PFV) }
-             hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
-             disposetree(p);
-             firstpass(hp);
-             p:=hp;
-             exit;
-          end;
-        if p^.convtyp<>tc_equal then
-          firstconvert[p^.convtyp](p);
-      end;
-
-
-{*****************************************************************************
-                                FirstIs
-*****************************************************************************}
-
-    procedure firstis(var p : ptree);
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-
-         if (p^.right^.resulttype^.deftype<>classrefdef) then
-           CGMessage(type_e_mismatch);
-
-         left_right_max(p);
-
-         { left must be a class }
-         if (p^.left^.resulttype^.deftype<>objectdef) or
-            not(pobjectdef(p^.left^.resulttype)^.is_class) then
-           CGMessage(type_e_mismatch);
-
-         { the operands must be related }
-         if (not(pobjectdef(p^.left^.resulttype)^.is_related(
-           pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and
-           (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related(
-           pobjectdef(p^.left^.resulttype)))) then
-           CGMessage(type_e_mismatch);
-
-         p^.location.loc:=LOC_FLAGS;
-         p^.resulttype:=booldef;
-      end;
-
-
-{*****************************************************************************
-                                FirstAs
-*****************************************************************************}
-
-    procedure firstas(var p : ptree);
-      begin
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           exit;
-
-         if (p^.right^.resulttype^.deftype<>classrefdef) then
-           CGMessage(type_e_mismatch);
-
-         left_right_max(p);
-
-         { left must be a class }
-         if (p^.left^.resulttype^.deftype<>objectdef) or
-           not(pobjectdef(p^.left^.resulttype)^.is_class) then
-           CGMessage(type_e_mismatch);
-
-         { the operands must be related }
-         if (not(pobjectdef(p^.left^.resulttype)^.is_related(
-           pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and
-           (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related(
-           pobjectdef(p^.left^.resulttype)))) then
-           CGMessage(type_e_mismatch);
-
-         set_location(p^.location,p^.left^.location);
-         p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.pointertype.def;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.9  2000/09/24 21:19:52  peter
-    * delphi compile fixes
-
-  Revision 1.8  2000/09/24 15:06:31  peter
-    * use defines.inc
-
-  Revision 1.7  2000/08/27 16:11:55  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.6  2000/08/26 19:40:19  peter
-    * integer(char) explicit typecast support (tp7,delphi compatible)
-
-  Revision 1.5  2000/08/02 07:20:32  jonas
-      - undid my changes from the previous two commits because it was a bug
-        in cg386cnv which I've now fixed (previous changes only masked it in
-        some cases) (merged from fixes branch)
-
-  Revision 1.4  2000/08/01 10:41:35  jonas
-    * refined my previous IE(10) fix (in some cases, too many registers could
-      be reserved) (merged from fixes branch)
-
-  Revision 1.3  2000/07/21 09:23:47  jonas
-    * merged from fixes branch
-
-  Revision 1.2  2000/07/13 11:32:51  michael
-  + removed logs
-
-}

compiler/old/tccon.pas

@@ -1,151 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for constants
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tccon;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstrealconst(var p : ptree);
-    procedure firstfixconst(var p : ptree);
-    procedure firstordconst(var p : ptree);
-    procedure firstpointerconst(var p : ptree);
-    procedure firststringconst(var p : ptree);
-    procedure firstsetconst(var p : ptree);
-    procedure firstniln(var p : ptree);
-
-
-implementation
-
-    uses
-      cobjects,verbose,globals,systems,
-      symconst,symtable,aasm,types,
-      hcodegen,pass_1,cpubase;
-
-{*****************************************************************************
-                             FirstRealConst
-*****************************************************************************}
-
-    procedure firstrealconst(var p : ptree);
-      begin
-         if (p^.value_real=1.0) or (p^.value_real=0.0) then
-           begin
-              p^.location.loc:=LOC_FPU;
-              p^.registersfpu:=1;
-           end
-         else
-           p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             FirstFixConst
-*****************************************************************************}
-
-    procedure firstfixconst(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             FirstOrdConst
-*****************************************************************************}
-
-    procedure firstordconst(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                             FirstPointerConst
-*****************************************************************************}
-
-    procedure firstpointerconst(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                            FirstStringConst
-*****************************************************************************}
-
-    procedure firststringconst(var p : ptree);
-      begin
-{        if cs_ansistrings in aktlocalswitches then
-          p^.resulttype:=cansistringdef
-         else
-          p^.resulttype:=cshortstringdef; }
-        case p^.stringtype of
-          st_shortstring :
-            p^.resulttype:=cshortstringdef;
-          st_ansistring :
-            p^.resulttype:=cansistringdef;
-          st_widestring :
-            p^.resulttype:=cwidestringdef;
-          st_longstring :
-            p^.resulttype:=clongstringdef;
-        end;
-        p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                           FirstSetConst
-*****************************************************************************}
-
-    procedure firstsetconst(var p : ptree);
-      begin
-         p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                              FirstNilN
-*****************************************************************************}
-
-    procedure firstniln(var p : ptree);
-      begin
-        p^.resulttype:=voidpointerdef;
-        p^.location.loc:=LOC_MEM;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.3  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.2  2000/07/13 11:32:51  michael
-  + removed logs
-
-}

compiler/old/tcflw.pas

@@ -1,674 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for nodes that influence
-    the flow
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcflw;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure first_while_repeat(var p : ptree);
-    procedure firstif(var p : ptree);
-    procedure firstfor(var p : ptree);
-    procedure firstexit(var p : ptree);
-    procedure firstgoto(var p : ptree);
-    procedure firstlabel(var p : ptree);
-    procedure firstraise(var p : ptree);
-    procedure firsttryexcept(var p : ptree);
-    procedure firsttryfinally(var p : ptree);
-    procedure firston(var p : ptree);
-
-var
-   { the block node of the current exception block to check gotos }
-   aktexceptblock : ptree;
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,htypechk,pass_1,cpubase
-{$ifdef newcg}
-      ,tgobj
-      ,tgcpu
-      ,cgbase
-{$else newcg}
-      ,hcodegen
-      ,temp_gen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$ifdef m68k}
-      ,tgen68k
-{$endif m68k}
-{$endif newcg}
-      ;
-
-{*****************************************************************************
-                         First_While_RepeatN
-*****************************************************************************}
-
-    procedure first_while_repeat(var p : ptree);
-      var
-         old_t_times : longint;
-      begin
-         old_t_times:=t_times;
-
-         { calc register weight }
-         if not(cs_littlesize in aktglobalswitches ) then
-           t_times:=t_times*8;
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           exit;
-         if not is_boolean(p^.left^.resulttype) then
-           begin
-             CGMessage(type_e_mismatch);
-             exit;
-           end;
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-         { loop instruction }
-         if assigned(p^.right) then
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(p^.right);
-              if codegenerror then
-                exit;
-
-              if p^.registers32<p^.right^.registers32 then
-                p^.registers32:=p^.right^.registers32;
-              if p^.registersfpu<p^.right^.registersfpu then
-                p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if p^.registersmmx<p^.right^.registersmmx then
-                p^.registersmmx:=p^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-
-         t_times:=old_t_times;
-      end;
-
-
-{*****************************************************************************
-                               FirstIfN
-*****************************************************************************}
-
-    procedure firstif(var p : ptree);
-      var
-         old_t_times : longint;
-         hp : ptree;
-      begin
-         old_t_times:=t_times;
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-
-         { Only check type if no error, we can't leave here because
-           the p^.right also needs to be firstpassed }
-         if not codegenerror then
-          begin
-            if not is_boolean(p^.left^.resulttype) then
-              Message1(type_e_boolean_expr_expected,p^.left^.resulttype^.typename);
-          end;
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-         { determines registers weigths }
-         if not(cs_littlesize in aktglobalswitches) then
-           t_times:=t_times div 2;
-         if t_times=0 then
-           t_times:=1;
-
-         { if path }
-         if assigned(p^.right) then
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(p^.right);
-
-              if p^.registers32<p^.right^.registers32 then
-                p^.registers32:=p^.right^.registers32;
-              if p^.registersfpu<p^.right^.registersfpu then
-                p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if p^.registersmmx<p^.right^.registersmmx then
-                p^.registersmmx:=p^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-
-         { else path }
-         if assigned(p^.t1) then
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(p^.t1);
-
-              if p^.registers32<p^.t1^.registers32 then
-                p^.registers32:=p^.t1^.registers32;
-              if p^.registersfpu<p^.t1^.registersfpu then
-                p^.registersfpu:=p^.t1^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if p^.registersmmx<p^.t1^.registersmmx then
-                p^.registersmmx:=p^.t1^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-
-         { leave if we've got an error in one of the paths }
-
-         if codegenerror then
-           exit;
-
-         if p^.left^.treetype=ordconstn then
-           begin
-              { optimize }
-              if p^.left^.value=1 then
-                begin
-                   disposetree(p^.left);
-                   hp:=p^.right;
-                   disposetree(p^.t1);
-                   { we cannot set p to nil !!! }
-                   if assigned(hp) then
-                     begin
-                        putnode(p);
-                        p:=hp;
-                     end
-                   else
-                     begin
-                        p^.left:=nil;
-                        p^.t1:=nil;
-                        p^.treetype:=nothingn;
-                     end;
-                end
-              else
-                begin
-                   disposetree(p^.left);
-                   hp:=p^.t1;
-                   disposetree(p^.right);
-                   { we cannot set p to nil !!! }
-                   if assigned(hp) then
-                     begin
-                        putnode(p);
-                        p:=hp;
-                     end
-                   else
-                     begin
-                        p^.left:=nil;
-                        p^.right:=nil;
-                        p^.treetype:=nothingn;
-                     end;
-                end;
-           end;
-
-         t_times:=old_t_times;
-      end;
-
-
-{*****************************************************************************
-                               FirstFor
-*****************************************************************************}
-
-    procedure firstfor(var p : ptree);
-
-      var
-         old_t_times : longint;
-         hp : ptree;
-      begin
-         { Calc register weight }
-         old_t_times:=t_times;
-         if not(cs_littlesize in aktglobalswitches) then
-           t_times:=t_times*8;
-         { save counter var }
-         p^.t2:=getcopy(p^.left^.left);
-
-         if p^.left^.treetype<>assignn then
-           CGMessage(cg_e_illegal_expression);
-
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         firstpass(p^.left);
-         set_varstate(p^.left,false);
-
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         if assigned(p^.t1) then
-          begin
-            firstpass(p^.t1);
-            if codegenerror then
-             exit;
-          end;
-
-         p^.registers32:=p^.t1^.registers32;
-         p^.registersfpu:=p^.t1^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         if p^.left^.registers32>p^.registers32 then
-           p^.registers32:=p^.left^.registers32;
-         if p^.left^.registersfpu>p^.registersfpu then
-           p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if p^.left^.registersmmx>p^.registersmmx then
-           p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-         { process count var }
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         firstpass(p^.t2);
-         set_varstate(p^.t2,true);
-         if codegenerror then
-          exit;
-
-         { Check count var, record fields are also allowed in tp7 }
-         hp:=p^.t2;
-         while (hp^.treetype=subscriptn) do
-          hp:=hp^.left;
-         { we need a simple loadn, but the load must be in a global symtable or
-           in the same lexlevel }
-         if (hp^.treetype=funcretn) or
-            ((hp^.treetype=loadn) and
-             ((hp^.symtable^.symtablelevel<=1) or
-              (hp^.symtable^.symtablelevel=lexlevel))) then
-          begin
-            if hp^.symtableentry^.typ=varsym then
-              pvarsym(hp^.symtableentry)^.varstate:=vs_used;
-            if (not(is_ordinal(p^.t2^.resulttype)) or is_64bitint(p^.t2^.resulttype)) then
-              CGMessagePos(hp^.fileinfo,type_e_ordinal_expr_expected);
-          end
-         else
-          CGMessagePos(hp^.fileinfo,cg_e_illegal_count_var);
-
-         if p^.t2^.registers32>p^.registers32 then
-           p^.registers32:=p^.t2^.registers32;
-         if p^.t2^.registersfpu>p^.registersfpu then
-           p^.registersfpu:=p^.t2^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if p^.t2^.registersmmx>p^.registersmmx then
-           p^.registersmmx:=p^.t2^.registersmmx;
-{$endif SUPPORT_MMX}
-
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if p^.right^.treetype<>ordconstn then
-           begin
-              p^.right:=gentypeconvnode(p^.right,p^.t2^.resulttype);
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(p^.right);
-           end;
-
-         if p^.right^.registers32>p^.registers32 then
-           p^.registers32:=p^.right^.registers32;
-         if p^.right^.registersfpu>p^.registersfpu then
-           p^.registersfpu:=p^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         if p^.right^.registersmmx>p^.registersmmx then
-           p^.registersmmx:=p^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-         { we need at least one register for comparisons PM }
-         if p^.registers32=0 then
-           inc(p^.registers32);
-         t_times:=old_t_times;
-      end;
-
-
-{*****************************************************************************
-                              FirstExit
-*****************************************************************************}
-
-    procedure firstexit(var p : ptree);
-      var
-         pt : ptree;
-      begin
-         p^.resulttype:=voiddef;
-         if assigned(p^.left) then
-           begin
-              firstpass(p^.left);
-              procinfo^.funcret_state:=vs_assigned;
-              if codegenerror then
-               exit;
-              { Check the 2 types }
-              p^.left:=gentypeconvnode(p^.left,procinfo^.returntype.def);
-              firstpass(p^.left);
-              if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then
-                begin
-                  pt:=genzeronode(funcretn);
-                  pt^.rettype.setdef(procinfo^.returntype.def);
-                  pt^.funcretprocinfo:=procinfo;
-                  p^.left:=gennode(assignn,pt,p^.left);
-                  firstpass(p^.left);
-                end;
-              p^.registers32:=p^.left^.registers32;
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-      end;
-
-
-{*****************************************************************************
-                             FirstGoto
-*****************************************************************************}
-
-    procedure firstgoto(var p : ptree);
-      begin
-         p^.resulttype:=voiddef;
-      end;
-
-
-{*****************************************************************************
-                             FirstLabel
-*****************************************************************************}
-
-    procedure firstlabel(var p : ptree);
-      begin
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         p^.exceptionblock:=aktexceptblock;
-         firstpass(p^.left);
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=voiddef;
-      end;
-
-
-{*****************************************************************************
-                             FirstRaise
-*****************************************************************************}
-
-    procedure firstraise(var p : ptree);
-      begin
-         p^.resulttype:=voiddef;
-         if assigned(p^.left) then
-           begin
-              { first para must be a _class_ }
-              firstpass(p^.left);
-              if assigned(p^.left^.resulttype) and
-                 ((p^.left^.resulttype^.deftype<>objectdef) or
-                  not(pobjectdef(p^.left^.resulttype)^.is_class)) then
-                CGMessage(type_e_mismatch);
-              set_varstate(p^.left,true);
-              if codegenerror then
-               exit;
-              { insert needed typeconvs for addr,frame }
-              if assigned(p^.right) then
-               begin
-                 { addr }
-                 firstpass(p^.right);
-                 p^.right:=gentypeconvnode(p^.right,s32bitdef);
-                 firstpass(p^.right);
-                 if codegenerror then
-                  exit;
-                 { frame }
-                 if assigned(p^.frametree) then
-                  begin
-                    firstpass(p^.frametree);
-                    p^.frametree:=gentypeconvnode(p^.frametree,s32bitdef);
-                    firstpass(p^.frametree);
-                    if codegenerror then
-                     exit;
-                  end;
-               end;
-              left_right_max(p);
-           end;
-      end;
-
-
-{*****************************************************************************
-                             FirstTryExcept
-*****************************************************************************}
-
-    procedure firsttryexcept(var p : ptree);
-
-      var
-         oldexceptblock : ptree;
-
-      begin
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         oldexceptblock:=aktexceptblock;
-         aktexceptblock:=p^.left;
-         firstpass(p^.left);
-         aktexceptblock:=oldexceptblock;
-         { on statements }
-         if assigned(p^.right) then
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.right;
-              firstpass(p^.right);
-              aktexceptblock:=oldexceptblock;
-              p^.registers32:=max(p^.registers32,p^.right^.registers32);
-              p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx);
-{$endif SUPPORT_MMX}
-           end;
-         { else block }
-         if assigned(p^.t1) then
-           begin
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.t1;
-              firstpass(p^.t1);
-              aktexceptblock:=oldexceptblock;
-              p^.registers32:=max(p^.registers32,p^.t1^.registers32);
-              p^.registersfpu:=max(p^.registersfpu,p^.t1^.registersfpu);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.registersmmx,p^.t1^.registersmmx);
-{$endif SUPPORT_MMX}
-           end;
-      end;
-
-
-{*****************************************************************************
-                             FirstTryFinally
-*****************************************************************************}
-
-    procedure firsttryfinally(var p : ptree);
-
-      var
-         oldexceptblock : ptree;
-
-      begin
-         p^.resulttype:=voiddef;
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         oldexceptblock:=aktexceptblock;
-         aktexceptblock:=p^.left;
-         firstpass(p^.left);
-         aktexceptblock:=oldexceptblock;
-         set_varstate(p^.left,true);
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         oldexceptblock:=aktexceptblock;
-         aktexceptblock:=p^.right;
-         firstpass(p^.right);
-         aktexceptblock:=oldexceptblock;
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-         left_right_max(p);
-      end;
-
-
-{*****************************************************************************
-                                 FirstOn
-*****************************************************************************}
-
-    procedure firston(var p : ptree);
-
-      var
-         oldexceptblock : ptree;
-
-      begin
-         { that's really an example procedure for a firstpass :) }
-         if (p^.excepttype^.deftype<>objectdef) or
-           not(pobjectdef(p^.excepttype)^.is_class) then
-           CGMessage(type_e_mismatch);
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         p^.resulttype:=voiddef;
-         p^.registers32:=0;
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         if assigned(p^.left) then
-           begin
-              firstpass(p^.left);
-              p^.registers32:=p^.left^.registers32;
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         if assigned(p^.right) then
-           begin
-              oldexceptblock:=aktexceptblock;
-              aktexceptblock:=p^.right;
-              firstpass(p^.right);
-              aktexceptblock:=oldexceptblock;
-              p^.registers32:=max(p^.registers32,p^.right^.registers32);
-              p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu);
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx);
-{$endif SUPPORT_MMX}
-           end;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.9  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.8  2000/09/10 21:19:40  peter
-    * fixed for counter var check (merged)
-
-  Revision 1.7  2000/09/03 11:44:00  peter
-    * error for not specified operand size, which is now required for
-      newer binutils (merged)
-    * previous commit fix for tcflw (merged)
-
-  Revision 1.6  2000/09/03 11:08:42  peter
-    * fixed counter var checking with funcretn (merged)
-
-  Revision 1.5  2000/08/27 16:11:55  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.4  2000/08/12 15:41:15  peter
-    * fixed bug 1096 (merged)
-
-  Revision 1.3  2000/08/02 07:04:56  jonas
-    * fixed crash when an undeclared identifier is used in a raise statement
-      (merged from fixes branch)
-
-  Revision 1.2  2000/07/13 11:32:51  michael
-  + removed logs
-
-}

compiler/old/tcinl.pas

@@ -1,1396 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for inline nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcinl;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstinline(var p : ptree);
-
-
-implementation
-
-    uses
-      cobjects,verbose,globals,systems,
-      globtype,
-      symconst,symtable,aasm,types,
-      htypechk,pass_1,
-      tccal,cpubase
-{$ifdef newcg}
-      ,cgbase
-      ,tgobj
-      ,tgcpu
-{$else newcg}
-      ,hcodegen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$endif newcg}
-      ;
-
-{*****************************************************************************
-                             FirstInLine
-*****************************************************************************}
-
-{$ifdef fpc}
-{$maxfpuregisters 0}
-{$endif fpc}
-    procedure firstinline(var p : ptree);
-      var
-         vl,vl2  : longint;
-         vr      : bestreal;
-         p1,hp,hpp  : ptree;
-{$ifndef NOCOLONCHECK}
-         frac_para,length_para : ptree;
-{$endif ndef NOCOLONCHECK}
-         extra_register,
-         isreal,
-         dowrite,
-         file_is_typed : boolean;
-
-      procedure do_lowhigh(adef : pdef);
-
-        var
-           v : longint;
-           enum : penumsym;
-
-        begin
-           case Adef^.deftype of
-             orddef:
-               begin
-                  if p^.inlinenumber=in_low_x then
-                    v:=porddef(adef)^.low
-                  else
-                    v:=porddef(adef)^.high;
-                  hp:=genordinalconstnode(v,adef);
-                  firstpass(hp);
-                  disposetree(p);
-                  p:=hp;
-               end;
-             enumdef:
-               begin
-                  enum:=Penumdef(Adef)^.firstenum;
-                  if p^.inlinenumber=in_high_x then
-                    while enum^.nextenum<>nil do
-                      enum:=enum^.nextenum;
-                  hp:=genenumnode(enum);
-                  disposetree(p);
-                  p:=hp;
-               end;
-           else
-             internalerror(87);
-           end;
-        end;
-
-      function getconstrealvalue : bestreal;
-
-        begin
-           case p^.left^.treetype of
-              ordconstn:
-                getconstrealvalue:=p^.left^.value;
-              realconstn:
-                getconstrealvalue:=p^.left^.value_real;
-              else
-                internalerror(309992);
-           end;
-        end;
-
-      procedure setconstrealvalue(r : bestreal);
-
-        var
-           hp : ptree;
-
-        begin
-           hp:=genrealconstnode(r,bestrealdef^);
-           disposetree(p);
-           p:=hp;
-           firstpass(p);
-        end;
-
-      procedure handleextendedfunction;
-
-        begin
-           p^.location.loc:=LOC_FPU;
-           p^.resulttype:=s80floatdef;
-           { redo firstpass for varstate status PM }
-           set_varstate(p^.left,true);
-           if (p^.left^.resulttype^.deftype<>floatdef) or
-             (pfloatdef(p^.left^.resulttype)^.typ<>s80real) then
-             begin
-                p^.left:=gentypeconvnode(p^.left,s80floatdef);
-                firstpass(p^.left);
-             end;
-           p^.registers32:=p^.left^.registers32;
-           p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-           p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-        end;
-
-      begin
-         { 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,false)
-              else
-                firstpass(p^.left);
-              left_right_max(p);
-              set_location(p^.location,p^.left^.location);
-           end;
-         inc(parsing_para_level);
-         { handle intern constant functions in separate case }
-         if p^.inlineconst then
-          begin
-            hp:=nil;
-            { no parameters? }
-            if not assigned(p^.left) then
-             begin
-               case p^.inlinenumber of
-                 in_const_pi :
-                   hp:=genrealconstnode(pi,bestrealdef^);
-                 else
-                   internalerror(89);
-               end;
-             end
-            else
-            { process constant expression with parameter }
-             begin
-               vl:=0;
-               vl2:=0; { second parameter Ex: ptr(vl,vl2) }
-               vr:=0;
-               isreal:=false;
-               case p^.left^.treetype of
-                 realconstn :
-                   begin
-                     isreal:=true;
-                     vr:=p^.left^.value_real;
-                   end;
-                 ordconstn :
-                   vl:=p^.left^.value;
-                 callparan :
-                   begin
-                     { both exists, else it was not generated }
-                     vl:=p^.left^.left^.value;
-                     vl2:=p^.left^.right^.left^.value;
-                   end;
-                 else
-                   CGMessage(cg_e_illegal_expression);
-               end;
-               case p^.inlinenumber of
-                 in_const_trunc :
-                   begin
-                     if isreal then
-                       begin
-                          if (vr>=2147483648.0) or (vr<=-2147483649.0) then
-                            begin
-                               CGMessage(parser_e_range_check_error);
-                               hp:=genordinalconstnode(1,s32bitdef)
-                            end
-                          else
-                            hp:=genordinalconstnode(trunc(vr),s32bitdef)
-                       end
-                     else
-                      hp:=genordinalconstnode(trunc(vl),s32bitdef);
-                   end;
-                 in_const_round :
-                   begin
-                     if isreal then
-                       begin
-                          if (vr>=2147483647.5) or (vr<=-2147483648.5) then
-                            begin
-                               CGMessage(parser_e_range_check_error);
-                               hp:=genordinalconstnode(1,s32bitdef)
-                            end
-                          else
-                            hp:=genordinalconstnode(round(vr),s32bitdef)
-                       end
-                     else
-                      hp:=genordinalconstnode(round(vl),s32bitdef);
-                   end;
-                 in_const_frac :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(frac(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(frac(vl),bestrealdef^);
-                   end;
-                 in_const_int :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(int(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(int(vl),bestrealdef^);
-                   end;
-                 in_const_abs :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(abs(vr),bestrealdef^)
-                     else
-                      hp:=genordinalconstnode(abs(vl),p^.left^.resulttype);
-                   end;
-                 in_const_sqr :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(sqr(vr),bestrealdef^)
-                     else
-                      hp:=genordinalconstnode(sqr(vl),p^.left^.resulttype);
-                   end;
-                 in_const_odd :
-                   begin
-                     if isreal then
-                      CGMessage1(type_e_integer_expr_expected,p^.left^.resulttype^.typename)
-                     else
-                      hp:=genordinalconstnode(byte(odd(vl)),booldef);
-                   end;
-                 in_const_swap_word :
-                   begin
-                     if isreal then
-                      CGMessage1(type_e_integer_expr_expected,p^.left^.resulttype^.typename)
-                     else
-                      hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),p^.left^.resulttype);
-                   end;
-                 in_const_swap_long :
-                   begin
-                     if isreal then
-                      CGMessage(type_e_mismatch)
-                     else
-                      hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),p^.left^.resulttype);
-                   end;
-                 in_const_ptr :
-                   begin
-                     if isreal then
-                      CGMessage(type_e_mismatch)
-                     else
-                      hp:=genordinalconstnode((vl2 shl 16) or vl,voidpointerdef);
-                   end;
-                 in_const_sqrt :
-                   begin
-                     if isreal then
-                       begin
-                          if vr<0.0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=genrealconstnode(sqrt(vr),bestrealdef^)
-                       end
-                     else
-                       begin
-                          if vl<0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=genrealconstnode(sqrt(vl),bestrealdef^);
-                       end;
-                   end;
-                 in_const_arctan :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(arctan(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(arctan(vl),bestrealdef^);
-                   end;
-                 in_const_cos :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(cos(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(cos(vl),bestrealdef^);
-                   end;
-                 in_const_sin :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(sin(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(sin(vl),bestrealdef^);
-                   end;
-                 in_const_exp :
-                   begin
-                     if isreal then
-                      hp:=genrealconstnode(exp(vr),bestrealdef^)
-                     else
-                      hp:=genrealconstnode(exp(vl),bestrealdef^);
-                   end;
-                 in_const_ln :
-                   begin
-                     if isreal then
-                       begin
-                          if vr<=0.0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=genrealconstnode(ln(vr),bestrealdef^)
-                       end
-                     else
-                       begin
-                          if vl<=0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=genrealconstnode(ln(vl),bestrealdef^);
-                       end;
-                   end;
-                 else
-                   internalerror(88);
-               end;
-             end;
-            disposetree(p);
-            if hp=nil then
-             hp:=genzeronode(errorn);
-            firstpass(hp);
-            p:=hp;
-          end
-         else
-          begin
-            case p^.inlinenumber of
-             in_lo_qword,
-             in_hi_qword,
-             in_lo_long,
-             in_hi_long,
-             in_lo_word,
-             in_hi_word:
-
-               begin
-                  set_varstate(p^.left,true);
-                  if p^.registers32<1 then
-                    p^.registers32:=1;
-                  if p^.inlinenumber in [in_lo_word,in_hi_word] then
-                    p^.resulttype:=u8bitdef
-                  else if p^.inlinenumber in [in_lo_qword,in_hi_qword] then
-                    begin
-                       p^.resulttype:=u32bitdef;
-                       if (m_tp in aktmodeswitches) or
-                          (m_delphi in aktmodeswitches) then
-                         CGMessage(type_w_maybe_wrong_hi_lo);
-                    end
-                  else
-                    begin
-                       p^.resulttype:=u16bitdef;
-                       if (m_tp in aktmodeswitches) or
-                          (m_delphi in aktmodeswitches) then
-                         CGMessage(type_w_maybe_wrong_hi_lo);
-                    end;
-                  p^.location.loc:=LOC_REGISTER;
-                  if not is_integer(p^.left^.resulttype) then
-                    CGMessage(type_e_mismatch)
-                  else
-                    begin
-                      if p^.left^.treetype=ordconstn then
-                       begin
-                         case p^.inlinenumber of
-                          in_lo_word : hp:=genordinalconstnode(p^.left^.value and $ff,p^.left^.resulttype);
-                          in_hi_word : hp:=genordinalconstnode(p^.left^.value shr 8,p^.left^.resulttype);
-                          in_lo_long : hp:=genordinalconstnode(p^.left^.value and $ffff,p^.left^.resulttype);
-                          in_hi_long : hp:=genordinalconstnode(p^.left^.value shr 16,p^.left^.resulttype);
-                          in_lo_qword : hp:=genordinalconstnode(p^.left^.value and $ffffffff,p^.left^.resulttype);
-                          in_hi_qword : hp:=genordinalconstnode(p^.left^.value shr 32,p^.left^.resulttype);
-                         end;
-                         disposetree(p);
-                         firstpass(hp);
-                         p:=hp;
-                       end;
-                    end;
-               end;
-
-             in_sizeof_x:
-               begin
-                 set_varstate(p^.left,false);
-                 if push_high_param(p^.left^.resulttype) then
-                  begin
-                    getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                    hp:=gennode(addn,genloadnode(pvarsym(srsym),p^.left^.symtable),
-                                     genordinalconstnode(1,s32bitdef));
-                    if (p^.left^.resulttype^.deftype=arraydef) and
-                       (parraydef(p^.left^.resulttype)^.elesize<>1) then
-                      hp:=gennode(muln,hp,genordinalconstnode(parraydef(p^.left^.resulttype)^.elesize,s32bitdef));
-                    disposetree(p);
-                    p:=hp;
-                    firstpass(p);
-                  end;
-                 if p^.registers32<1 then
-                    p^.registers32:=1;
-                 p^.resulttype:=s32bitdef;
-                 p^.location.loc:=LOC_REGISTER;
-               end;
-
-             in_typeof_x:
-               begin
-                  set_varstate(p^.left,false);
-                  if p^.registers32<1 then
-                    p^.registers32:=1;
-                  p^.location.loc:=LOC_REGISTER;
-                  p^.resulttype:=voidpointerdef;
-               end;
-
-             in_ord_x:
-               begin
-                  set_varstate(p^.left,true);
-                  if (p^.left^.treetype=ordconstn) then
-                    begin
-                       hp:=genordinalconstnode(p^.left^.value,s32bitdef);
-                       disposetree(p);
-                       p:=hp;
-                       firstpass(p);
-                    end
-                  else
-                    begin
-                       { otherwise you get a crash if you try ord on an expression containing }
-                       { an undeclared variable (JM)                                          }
-                       if not assigned(p^.left^.resulttype) then
-                         exit;
-                       if (p^.left^.resulttype^.deftype=orddef) then
-                         if (porddef(p^.left^.resulttype)^.typ in [uchar,uwidechar,bool8bit]) then
-                           case porddef(p^.left^.resulttype)^.typ of
-                            uchar:
-                               begin
-                                  hp:=gentypeconvnode(p^.left,u8bitdef);
-                                  putnode(p);
-                                  p:=hp;
-                                  p^.explizit:=true;
-                                  firstpass(p);
-                               end;
-                            uwidechar:
-                               begin
-                                  hp:=gentypeconvnode(p^.left,u16bitdef);
-                                  putnode(p);
-                                  p:=hp;
-                                  p^.explizit:=true;
-                                  firstpass(p);
-                               end;
-                            bool8bit:
-                               begin
-                                  hp:=gentypeconvnode(p^.left,u8bitdef);
-                                  putnode(p);
-                                  p:=hp;
-                                  p^.convtyp:=tc_bool_2_int;
-                                  p^.explizit:=true;
-                                  firstpass(p);
-                               end
-                           end
-                         { can this happen ? }
-                         else if (porddef(p^.left^.resulttype)^.typ=uvoid) then
-                           CGMessage(type_e_mismatch)
-                         else
-                           { all other orddef need no transformation }
-                           begin
-                              hp:=p^.left;
-                              putnode(p);
-                              p:=hp;
-                           end
-                       else if (p^.left^.resulttype^.deftype=enumdef) then
-                         begin
-                            hp:=gentypeconvnode(p^.left,s32bitdef);
-                            putnode(p);
-                            p:=hp;
-                            p^.explizit:=true;
-                            firstpass(p);
-                         end
-                       else
-                         begin
-                            { can anything else be ord() ?}
-                            CGMessage(type_e_mismatch);
-                         end;
-                    end;
-               end;
-
-             in_chr_byte:
-               begin
-                  set_varstate(p^.left,true);
-                  hp:=gentypeconvnode(p^.left,cchardef);
-                  putnode(p);
-                  p:=hp;
-                  p^.explizit:=true;
-                  firstpass(p);
-               end;
-
-             in_length_string:
-               begin
-                  set_varstate(p^.left,true);
-                  if is_ansistring(p^.left^.resulttype) then
-                    p^.resulttype:=s32bitdef
-                  else
-                    p^.resulttype:=u8bitdef;
-                  { we don't need string conversations here }
-                  if (p^.left^.treetype=typeconvn) and
-                     (p^.left^.left^.resulttype^.deftype=stringdef) then
-                    begin
-                       hp:=p^.left^.left;
-                       putnode(p^.left);
-                       p^.left:=hp;
-                    end;
-
-                  { check the type, must be string or char }
-                  if (p^.left^.resulttype^.deftype<>stringdef) and
-                     (not is_char(p^.left^.resulttype)) then
-                    CGMessage(type_e_mismatch);
-
-                  { evaluates length of constant strings direct }
-                  if (p^.left^.treetype=stringconstn) then
-                    begin
-                       hp:=genordinalconstnode(p^.left^.length,s32bitdef);
-                       disposetree(p);
-                       firstpass(hp);
-                       p:=hp;
-                    end
-                  { length of char is one allways }
-                  else if is_constcharnode(p^.left) then
-                    begin
-                       hp:=genordinalconstnode(1,s32bitdef);
-                       disposetree(p);
-                       firstpass(hp);
-                       p:=hp;
-                    end;
-               end;
-
-             in_typeinfo_x:
-               begin
-                  p^.resulttype:=voidpointerdef;
-                  p^.location.loc:=LOC_REGISTER;
-                  p^.registers32:=1;
-               end;
-
-             in_assigned_x:
-               begin
-                  set_varstate(p^.left,true);
-                  p^.resulttype:=booldef;
-                  p^.location.loc:=LOC_FLAGS;
-               end;
-
-             in_ofs_x,
-             in_seg_x :
-               set_varstate(p^.left,false);
-             in_pred_x,
-             in_succ_x:
-               begin
-                  p^.resulttype:=p^.left^.resulttype;
-                  if is_64bitint(p^.resulttype) then
-                    begin
-                       if (p^.registers32<2) then
-                         p^.registers32:=2
-                    end
-                  else
-                    begin
-                       if (p^.registers32<1) then
-                         p^.registers32:=1;
-                    end;
-                  p^.location.loc:=LOC_REGISTER;
-                  set_varstate(p^.left,true);
-                  if not is_ordinal(p^.resulttype) then
-                    CGMessage(type_e_ordinal_expr_expected)
-                  else
-                    begin
-                      if (p^.resulttype^.deftype=enumdef) and
-                         (penumdef(p^.resulttype)^.has_jumps) then
-                        CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible)
-                      else
-                        if p^.left^.treetype=ordconstn then
-                         begin
-                           if p^.inlinenumber=in_succ_x then
-                             hp:=genordinalconstnode(p^.left^.value+1,p^.left^.resulttype)
-                           else
-                             hp:=genordinalconstnode(p^.left^.value-1,p^.left^.resulttype);
-                           disposetree(p);
-                           firstpass(hp);
-                           p:=hp;
-                         end;
-                    end;
-               end;
-
-             in_inc_x,
-             in_dec_x:
-               begin
-                 p^.resulttype:=voiddef;
-                 if assigned(p^.left) then
-                   begin
-                      firstcallparan(p^.left,nil,true);
-                      set_varstate(p^.left,true);
-                      if codegenerror then
-                       exit;
-                      { first param must be var }
-                      valid_for_assign(p^.left^.left,false);
-                      { check type }
-                      if is_64bitint(p^.left^.resulttype) then
-                        { convert to simple add (JM) }
-                        begin
-                          hp := getnode;
-                          hp^.treetype := assignn;
-                          hp^.left := getcopy(p^.left^.left);
-                          hpp := getnode;
-                          hp^.right := hpp;
-                          if p^.inlinenumber = in_inc_x then
-                            hpp^.treetype := addn
-                          else hpp^.treetype := subn;
-                          hpp^.left := p^.left^.left;
-                          p^.left^.left := nil;
-                          if assigned(p^.left^.right) then
-                            begin
-                              hpp^.right := p^.left^.right^.left;
-                              p^.left^.right^.left := nil;
-                              if assigned(p^.left^.right^.right) then
-                                CGMessage(cg_e_illegal_expression);
-                            end
-                          else
-                            hpp^.right := genordinalconstnode(1,s32bitdef);
-                          disposetree(p);
-                          p := hp;
-                          dec(parsing_para_level);
-                          firstpass(p);
-                          exit;
-                        end; 
-                      if (p^.left^.resulttype^.deftype in [enumdef,pointerdef]) or
-                         is_ordinal(p^.left^.resulttype) then
-                        begin
-                           { two paras ? }
-                           if assigned(p^.left^.right) then
-                             begin
-                                { insert a type conversion       }
-                                { the second param is always longint }
-                                p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,s32bitdef);
-                                { check the type conversion }
-                                firstpass(p^.left^.right^.left);
-
-                                { need we an additional register ? }
-                                if not(is_constintnode(p^.left^.right^.left)) and
-                                  (p^.left^.right^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
-                                  (p^.left^.right^.left^.registers32<=1) then
-                                  inc(p^.registers32);
-
-                                { do we need an additional register to restore the first parameter? }
-                                if p^.left^.right^.left^.registers32>=p^.registers32 then
-                                  inc(p^.registers32);
-
-                                if assigned(p^.left^.right^.right) then
-                                  CGMessage(cg_e_illegal_expression);
-                             end;
-                        end
-                      else
-                        CGMessage(type_e_ordinal_expr_expected);
-                   end
-                 else
-                   CGMessage(type_e_mismatch);
-               end;
-
-             in_read_x,
-             in_readln_x,
-             in_write_x,
-             in_writeln_x :
-               begin
-                  { needs a call }
-                  procinfo^.flags:=procinfo^.flags or pi_do_call;
-                  p^.resulttype:=voiddef;
-                  { true, if readln needs an extra register }
-                  extra_register:=false;
-                  { we must know if it is a typed file or not }
-                  { but we must first do the firstpass for it }
-                  file_is_typed:=false;
-                  if assigned(p^.left) then
-                    begin
-                       dowrite:=(p^.inlinenumber in [in_write_x,in_writeln_x]);
-                       firstcallparan(p^.left,nil,true);
-                       set_varstate(p^.left,dowrite);
-                       { now we can check }
-                       hp:=p^.left;
-                       while assigned(hp^.right) do
-                         hp:=hp^.right;
-                       { if resulttype is not assigned, then automatically }
-                       { file is not typed.                             }
-                       if assigned(hp) and assigned(hp^.resulttype) then
-                         Begin
-                           if (hp^.resulttype^.deftype=filedef) then
-                           if (pfiledef(hp^.resulttype)^.filetyp=ft_untyped) then
-                             begin
-                              if (p^.inlinenumber in [in_readln_x,in_writeln_x]) then
-                                CGMessage(type_e_no_readln_writeln_for_typed_file)
-                              else
-                                CGMessage(type_e_no_read_write_for_untyped_file);
-                             end
-                           else if (pfiledef(hp^.resulttype)^.filetyp=ft_typed) then
-                            begin
-                              file_is_typed:=true;
-                              { test the type }
-                              if (p^.inlinenumber in [in_readln_x,in_writeln_x]) then
-                                CGMessage(type_e_no_readln_writeln_for_typed_file);
-                              hpp:=p^.left;
-                              while (hpp<>hp) do
-                               begin
-                                 if (hpp^.left^.treetype=typen) then
-                                   CGMessage(type_e_cant_read_write_type);
-                                 if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typedfiletype.def) then
-                                   CGMessage(type_e_mismatch);
-                                 { generate the high() value for the shortstring }
-                                 if ((not dowrite) and is_shortstring(hpp^.left^.resulttype)) or
-                                    (is_chararray(hpp^.left^.resulttype)) then
-                                   gen_high_tree(hpp,true);
-                                 { read(ln) is call by reference (JM) }
-                                 if not dowrite then
-                                   make_not_regable(hpp^.left);
-                                 hpp:=hpp^.right;
-                               end;
-                            end;
-                         end; { endif assigned(hp) }
-
-                       { insert type conversions for write(ln) }
-                       if (not file_is_typed) then
-                         begin
-                            hp:=p^.left;
-                            while assigned(hp) do
-                              begin
-                                incrementregisterpushed($ff);
-                                if (hp^.left^.treetype=typen) then
-                                  CGMessage(type_e_cant_read_write_type);
-                                if assigned(hp^.left^.resulttype) then
-                                  begin
-                                    isreal:=false;
-                                    { support writeln(procvar) }
-                                    if (hp^.left^.resulttype^.deftype=procvardef) then
-                                     begin
-                                       p1:=gencallnode(nil,nil);
-                                       p1^.right:=hp^.left;
-                                       p1^.resulttype:=pprocvardef(hp^.left^.resulttype)^.rettype.def;
-                                       firstpass(p1);
-                                       hp^.left:=p1;
-                                     end;
-                                    case hp^.left^.resulttype^.deftype of
-                                      filedef :
-                                        begin
-                                          { only allowed as first parameter }
-                                          if assigned(hp^.right) then
-                                            CGMessage(type_e_cant_read_write_type);
-                                        end;
-                                      stringdef :
-                                        begin
-                                          { generate the high() value for the shortstring }
-                                          if (not dowrite) and
-                                             is_shortstring(hp^.left^.resulttype) then
-                                            gen_high_tree(hp,true);
-                                        end;
-                                      pointerdef :
-                                        begin
-                                          if not is_pchar(hp^.left^.resulttype) then
-                                            CGMessage(type_e_cant_read_write_type);
-                                        end;
-                                      floatdef :
-                                        begin
-                                          isreal:=true;
-                                        end;
-                                      orddef :
-                                        begin
-                                          case porddef(hp^.left^.resulttype)^.typ of
-                                            uchar,
-                                            u32bit,s32bit,
-                                            u64bit,s64bit:
-                                              ;
-                                            u8bit,s8bit,
-                                            u16bit,s16bit :
-                                              if dowrite then
-                                                hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
-                                            bool8bit,
-                                            bool16bit,
-                                            bool32bit :
-                                              if dowrite then
-                                                hp^.left:=gentypeconvnode(hp^.left,booldef)
-                                              else
-                                                CGMessage(type_e_cant_read_write_type);
-                                            else
-                                              CGMessage(type_e_cant_read_write_type);
-                                          end;
-                                          if not(dowrite) and
-                                            not(is_64bitint(hp^.left^.resulttype)) then
-                                            extra_register:=true;
-                                        end;
-                                      arraydef :
-                                        begin
-                                          if is_chararray(hp^.left^.resulttype) then
-                                            gen_high_tree(hp,true)
-                                          else
-                                            CGMessage(type_e_cant_read_write_type);
-                                        end;
-                                      else
-                                        CGMessage(type_e_cant_read_write_type);
-                                    end;
-
-                                    { some format options ? }
-                                    if hp^.is_colon_para then
-                                      begin
-                                         if hp^.right^.is_colon_para then
-                                           begin
-                                              frac_para:=hp;
-                                              length_para:=hp^.right;
-                                              hp:=hp^.right;
-                                              hpp:=hp^.right;
-                                           end
-                                         else
-                                           begin
-                                              length_para:=hp;
-                                              frac_para:=nil;
-                                              hpp:=hp^.right;
-                                           end;
-                                         { can be nil if you use "write(e:0:6)" while e is undeclared (JM) }
-                                         if assigned(hpp^.left^.resulttype) then
-                                           isreal:=(hpp^.left^.resulttype^.deftype=floatdef)
-                                         else exit;
-                                         if (not is_integer(length_para^.left^.resulttype)) then
-                                          CGMessage1(type_e_integer_expr_expected,length_para^.left^.resulttype^.typename)
-                                        else
-                                          length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef);
-                                        if assigned(frac_para) then
-                                          begin
-                                            if isreal then
-                                             begin
-                                               if (not is_integer(frac_para^.left^.resulttype)) then
-                                                 CGMessage1(type_e_integer_expr_expected,frac_para^.left^.resulttype^.typename)
-                                               else
-                                                 frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef);
-                                             end
-                                            else
-                                             CGMessage(parser_e_illegal_colon_qualifier);
-                                          end;
-                                        { do the checking for the colon'd arg }
-                                        hp:=length_para;
-                                      end;
-                                  end;
-                                 hp:=hp^.right;
-                              end;
-                         end;
-                       { pass all parameters again for the typeconversions }
-                       if codegenerror then
-                         exit;
-                       firstcallparan(p^.left,nil,true);
-                       set_varstate(p^.left,true);
-                       { calc registers }
-                       left_right_max(p);
-                       if extra_register then
-                         inc(p^.registers32);
-                    end;
-               end;
-
-            in_settextbuf_file_x :
-              begin
-                 { warning here p^.left is the callparannode
-                   not the argument directly }
-                 { p^.left^.left is text var }
-                 { p^.left^.right^.left is the buffer var }
-                 { firstcallparan(p^.left,nil);
-                   already done in firstcalln }
-                 { now we know the type of buffer }
-                 getsymonlyin(systemunit,'SETTEXTBUF');
-                 hp:=gencallnode(pprocsym(srsym),systemunit);
-                 hp^.left:=gencallparanode(
-                   genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
-                 putnode(p);
-                 p:=hp;
-                 firstpass(p);
-              end;
-
-             { the firstpass of the arg has been done in firstcalln ? }
-             in_reset_typedfile,
-             in_rewrite_typedfile :
-               begin
-                  procinfo^.flags:=procinfo^.flags or pi_do_call;
-                  firstpass(p^.left);
-                  set_varstate(p^.left,true);
-                  p^.resulttype:=voiddef;
-               end;
-
-             in_str_x_string :
-               begin
-                  procinfo^.flags:=procinfo^.flags or pi_do_call;
-                  p^.resulttype:=voiddef;
-                  { check the amount of parameters }
-                  if not(assigned(p^.left)) or
-                     not(assigned(p^.left^.right)) then
-                   begin
-                     CGMessage(parser_e_wrong_parameter_size);
-                     exit;
-                   end;
-                  { first pass just the string for first local use }
-                  hp:=p^.left^.right;
-                  p^.left^.right:=nil;
-                  firstcallparan(p^.left,nil,true);
-                  set_varstate(p^.left,false);
-                  { remove warning when result is passed }
-                  set_funcret_is_valid(p^.left^.left);
-                  p^.left^.right:=hp;
-                  firstcallparan(p^.left^.right,nil,true);
-                  set_varstate(p^.left^.right,true);
-                  hp:=p^.left;
-                  { valid string ? }
-                  if not assigned(hp) or
-                     (hp^.left^.resulttype^.deftype<>stringdef) or
-                     (hp^.right=nil) then
-                    CGMessage(cg_e_illegal_expression);
-                  { we need a var parameter }
-                  valid_for_assign(hp^.left,false);
-                  { generate the high() value for the shortstring }
-                  if is_shortstring(hp^.left^.resulttype) then
-                    gen_high_tree(hp,true);
-
-                  { !!!! check length of string }
-
-                  while assigned(hp^.right) do
-                    hp:=hp^.right;
-
-                  if not assigned(hp^.resulttype) then
-                    exit;
-                  { check and convert the first param }
-                  if (hp^.is_colon_para) or
-                     not assigned(hp^.resulttype) then
-                    CGMessage(cg_e_illegal_expression);
-
-                  isreal:=false;
-                  case hp^.resulttype^.deftype of
-                    orddef :
-                      begin
-                        case porddef(hp^.left^.resulttype)^.typ of
-                          u32bit,s32bit,
-                          s64bit,u64bit:
-                            ;
-                          u8bit,s8bit,
-                          u16bit,s16bit:
-                            hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
-                          else
-                            CGMessage(type_e_integer_or_real_expr_expected);
-                        end;
-                      end;
-                    floatdef :
-                      begin
-                        isreal:=true;
-                      end;
-                    else
-                      CGMessage(type_e_integer_or_real_expr_expected);
-                  end;
-
-                  { some format options ? }
-                  hpp:=p^.left^.right;
-                  if assigned(hpp) and hpp^.is_colon_para then
-                    begin
-                      firstpass(hpp^.left);
-                      set_varstate(hpp^.left,true);
-                      if (not is_integer(hpp^.left^.resulttype)) then
-                        CGMessage1(type_e_integer_expr_expected,hpp^.left^.resulttype^.typename)
-                      else
-                        hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
-                      hpp:=hpp^.right;
-                      if assigned(hpp) and hpp^.is_colon_para then
-                        begin
-                          if isreal then
-                           begin
-                             if (not is_integer(hpp^.left^.resulttype)) then
-                               CGMessage1(type_e_integer_expr_expected,hpp^.left^.resulttype^.typename)
-                             else
-                               begin
-                                 firstpass(hpp^.left);
-                                 set_varstate(hpp^.left,true);
-                                 hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
-                               end;
-                           end
-                          else
-                           CGMessage(parser_e_illegal_colon_qualifier);
-                        end;
-                    end;
-
-                  { pass all parameters again for the typeconversions }
-                  if codegenerror then
-                    exit;
-                  firstcallparan(p^.left,nil,true);
-                  { calc registers }
-                  left_right_max(p);
-               end;
-
-             in_val_x :
-               begin
-                  procinfo^.flags:=procinfo^.flags or pi_do_call;
-                  p^.resulttype:=voiddef;
-                  { check the amount of parameters }
-                  if not(assigned(p^.left)) or
-                     not(assigned(p^.left^.right)) then
-                   begin
-                     CGMessage(parser_e_wrong_parameter_size);
-                     exit;
-                   end;
-                  If Assigned(p^.left^.right^.right) Then
-                   {there is a "code" parameter}
-                     Begin
-                  { first pass just the code parameter for first local use}
-                       hp := p^.left^.right;
-                       p^.left^.right := nil;
-                       make_not_regable(p^.left^.left);
-                       firstcallparan(p^.left, nil,true);
-                       set_varstate(p^.left,false);
-                       if codegenerror then exit;
-                       p^.left^.right := hp;
-                     {code has to be a var parameter}
-                       if valid_for_assign(p^.left^.left,false) then
-                        begin
-                          if (p^.left^.left^.resulttype^.deftype <> orddef) or
-                            not(porddef(p^.left^.left^.resulttype)^.typ in
-                                [u16bit,s16bit,u32bit,s32bit]) then
-                           CGMessage(type_e_mismatch);
-                        end;
-                       hpp := p^.left^.right
-                     End
-                  Else hpp := p^.left;
-                  {now hpp = the destination value tree}
-                  { first pass just the destination parameter for first local use}
-                  hp:=hpp^.right;
-                  hpp^.right:=nil;
-                  {hpp = destination}
-                  make_not_regable(hpp^.left);
-                  firstcallparan(hpp,nil,true);
-                  set_varstate(hpp,false);
-
-                  if codegenerror then
-                    exit;
-                  { remove warning when result is passed }
-                  set_funcret_is_valid(hpp^.left);
-                  hpp^.right := hp;
-                  if valid_for_assign(hpp^.left,false) then
-                   begin
-                     If Not((hpp^.left^.resulttype^.deftype = floatdef) or
-                            ((hpp^.left^.resulttype^.deftype = orddef) And
-                             (POrdDef(hpp^.left^.resulttype)^.typ in
-                              [u32bit,s32bit,
-                               u8bit,s8bit,u16bit,s16bit,s64bit,u64bit]))) Then
-                       CGMessage(type_e_mismatch);
-                   end;
-                 {hp = source (String)}
-                  { count_ref := false; WHY ?? }
-                  firstcallparan(hp,nil,true);
-                  set_varstate(hp,true);
-                  if codegenerror then
-                    exit;
-                  { if not a stringdef then insert a type conv which
-                    does the other type checking }
-                  If (hp^.left^.resulttype^.deftype<>stringdef) then
-                   begin
-                     hp^.left:=gentypeconvnode(hp^.left,cshortstringdef);
-                     firstpass(hp);
-                   end;
-                  { calc registers }
-                  left_right_max(p);
-
-                  { val doesn't calculate the registers really }
-                  { correct, we need one register extra   (FK) }
-                  if is_64bitint(hpp^.left^.resulttype) then
-                    inc(p^.registers32,2)
-                  else
-                    inc(p^.registers32,1);
-               end;
-
-             in_include_x_y,
-             in_exclude_x_y:
-               begin
-                 p^.resulttype:=voiddef;
-                 if assigned(p^.left) then
-                   begin
-                      firstcallparan(p^.left,nil,true);
-                      set_varstate(p^.left,true);
-                      p^.registers32:=p^.left^.registers32;
-                      p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-                      p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-                      { remove warning when result is passed }
-                      set_funcret_is_valid(p^.left^.left);
-                      { first param must be var }
-                      valid_for_assign(p^.left^.left,false);
-                      { check type }
-                      if assigned(p^.left^.resulttype) and
-                         (p^.left^.resulttype^.deftype=setdef) then
-                        begin
-                           { two paras ? }
-                           if assigned(p^.left^.right) then
-                             begin
-                                { insert a type conversion       }
-                                { to the type of the set elements  }
-                                p^.left^.right^.left:=gentypeconvnode(
-                                  p^.left^.right^.left,
-                                  psetdef(p^.left^.resulttype)^.elementtype.def);
-                                { check the type conversion }
-                                firstpass(p^.left^.right^.left);
-                                { only three parameters are allowed }
-                                if assigned(p^.left^.right^.right) then
-                                  CGMessage(cg_e_illegal_expression);
-                             end;
-                        end
-                      else
-                        CGMessage(type_e_mismatch);
-                   end
-                 else
-                   CGMessage(type_e_mismatch);
-               end;
-
-             in_low_x,
-             in_high_x:
-               begin
-                  set_varstate(p^.left,false);
-                  { this fixes tests\webtbs\tbug879.pp (FK)
-                  if p^.left^.treetype in [typen,loadn,subscriptn] then
-                    begin
-                  }
-                       case p^.left^.resulttype^.deftype of
-                          orddef,enumdef:
-                            begin
-                               do_lowhigh(p^.left^.resulttype);
-                               firstpass(p);
-                            end;
-                          setdef:
-                            begin
-                               do_lowhigh(Psetdef(p^.left^.resulttype)^.elementtype.def);
-                               firstpass(p);
-                            end;
-                         arraydef:
-                            begin
-                              if p^.inlinenumber=in_low_x then
-                               begin
-                                 hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,
-                                   Parraydef(p^.left^.resulttype)^.rangetype.def);
-                                 disposetree(p);
-                                 p:=hp;
-                                 firstpass(p);
-                               end
-                              else
-                               begin
-                                 if is_open_array(p^.left^.resulttype) or
-                                   is_array_of_const(p^.left^.resulttype) then
-                                  begin
-                                    getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                                    hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
-                                    disposetree(p);
-                                    p:=hp;
-                                    firstpass(p);
-                                  end
-                                 else
-                                  begin
-                                    hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,
-                                      Parraydef(p^.left^.resulttype)^.rangetype.def);
-                                    disposetree(p);
-                                    p:=hp;
-                                    firstpass(p);
-                                  end;
-                               end;
-                           end;
-                         stringdef:
-                           begin
-                              if p^.inlinenumber=in_low_x then
-                               begin
-                                 hp:=genordinalconstnode(0,u8bitdef);
-                                 disposetree(p);
-                                 p:=hp;
-                                 firstpass(p);
-                               end
-                              else
-                               begin
-                                 if is_open_string(p^.left^.resulttype) then
-                                  begin
-                                    getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
-                                    hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
-                                    disposetree(p);
-                                    p:=hp;
-                                    firstpass(p);
-                                  end
-                                 else
-                                  begin
-                                    hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
-                                    disposetree(p);
-                                    p:=hp;
-                                    firstpass(p);
-                                  end;
-                               end;
-                           end;
-                         else
-                           CGMessage(type_e_mismatch);
-                         end;
-                  {
-                    end
-                  else
-                    CGMessage(type_e_varid_or_typeid_expected);
-                  }
-               end;
-
-             in_cos_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    setconstrealvalue(cos(getconstrealvalue))
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_sin_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    setconstrealvalue(sin(getconstrealvalue))
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_arctan_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    setconstrealvalue(arctan(getconstrealvalue))
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_pi:
-               if block_type=bt_const then
-                 setconstrealvalue(pi)
-               else
-                 begin
-                    p^.location.loc:=LOC_FPU;
-                    p^.resulttype:=s80floatdef;
-                 end;
-
-             in_abs_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    setconstrealvalue(abs(getconstrealvalue))
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_sqr_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    setconstrealvalue(sqr(getconstrealvalue))
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_sqrt_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    begin
-                       vr:=getconstrealvalue;
-                       if vr<0.0 then
-                         begin
-                            CGMessage(type_e_wrong_math_argument);
-                            setconstrealvalue(0);
-                         end
-                       else
-                         setconstrealvalue(sqrt(vr));
-                    end
-                  else
-                    handleextendedfunction;
-               end;
-
-             in_ln_extended:
-               begin
-                  if p^.left^.treetype in [ordconstn,realconstn] then
-                    begin
-                       vr:=getconstrealvalue;
-                       if vr<=0.0 then
-                         begin
-                            CGMessage(type_e_wrong_math_argument);
-                            setconstrealvalue(0);
-                         end
-                       else
-                         setconstrealvalue(ln(vr));
-                    end
-                  else
-                    handleextendedfunction;
-               end;
-
-{$ifdef SUPPORT_MMX}
-            in_mmx_pcmpeqb..in_mmx_pcmpgtw:
-              begin
-              end;
-{$endif SUPPORT_MMX}
-            in_assert_x_y :
-               begin
-                 p^.resulttype:=voiddef;
-                 if assigned(p^.left) then
-                   begin
-                      firstcallparan(p^.left,nil,true);
-                      set_varstate(p^.left,true);
-                      p^.registers32:=p^.left^.registers32;
-                      p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-                      p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-                      { check type }
-                      if is_boolean(p^.left^.resulttype) then
-                        begin
-                           { must always be a string }
-                           p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,cshortstringdef);
-                           firstpass(p^.left^.right^.left);
-                        end
-                      else
-                        CGMessage(type_e_mismatch);
-                   end
-                 else
-                   CGMessage(type_e_mismatch);
-                 { We've checked the whole statement for correctness, now we
-                   can remove it if assertions are off }
-                 if not(cs_do_assertion in aktlocalswitches) then
-                  begin
-                    disposetree(p^.left);
-                    putnode(p);
-                    { we need a valid node, so insert a nothingn }
-                    p:=genzeronode(nothingn);
-                  end;
-               end;
-
-              else
-               internalerror(8);
-             end;
-            end;
-           { generate an error if no resulttype is set }
-           if not assigned(p^.resulttype) then
-             p^.resulttype:=generrordef;
-         dec(parsing_para_level);
-       end;
-{$ifdef fpc}
-{$maxfpuregisters default}
-{$endif fpc}
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.8  2000/10/05 14:42:31  jonas
-    * fixed inc/dec with a 64bit type (merged from fixes branch)
-
-  Revision 1.7  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.6  2000/08/24 13:12:38  jonas
-    * fixed crash when using include/exclude with undeclared variable as
-      first parameter (merged from fixes branch)
-
-  Revision 1.5  2000/08/16 13:06:07  florian
-    + support of 64 bit integer constants
-
-  Revision 1.4  2000/08/01 14:07:49  jonas
-    * fixed crash when passing undeclared identifiers to str() (merged from
-      fixes branch)
-
-  Revision 1.3  2000/07/22 11:53:26  sg
-  * Added WideChar support to inlined 'ord' function
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-
-}

compiler/old/tcld.pas

@@ -1,546 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for load/assignment nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcld;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstload(var p : ptree);
-    procedure firstassignment(var p : ptree);
-    procedure firstfuncret(var p : ptree);
-    procedure firstarrayconstructrange(var p:ptree);
-    procedure firstarrayconstruct(var p : ptree);
-    procedure firsttype(var p : ptree);
-
-
-implementation
-
-    uses
-      cutils,cobjects,verbose,globtype,globals,systems,
-      symconst,symtable,aasm,types,
-      htypechk,pass_1,
-      tccnv,cpubase
-{$ifdef newcg}
-      ,cgbase
-      ,tgobj
-      ,tgcpu
-{$else newcg}
-      ,hcodegen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$endif newcg}
-      ;
-
-{*****************************************************************************
-                               FirstLoad
-*****************************************************************************}
-
-    procedure firstload(var p : ptree);
-      var
-         p1 : ptree;
-      begin
-         if (p^.symtable^.symtabletype=withsymtable) and
-            (pwithsymtable(p^.symtable)^.direct_with) and
-            (p^.symtableentry^.typ=varsym) then
-           begin
-              p1:=getcopy(ptree(pwithsymtable(p^.symtable)^.withrefnode));
-              p1:=gensubscriptnode(pvarsym(p^.symtableentry),p1);
-              putnode(p);
-              p:=p1;
-              firstpass(p);
-              exit;
-           end;
-
-         p^.location.loc:=LOC_REFERENCE;
-         p^.registers32:=0;
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         { handle first absolute as it will replace the p^.symtableentry }
-         if p^.symtableentry^.typ=absolutesym then
-           begin
-             p^.resulttype:=pabsolutesym(p^.symtableentry)^.vartype.def;
-             { replace the symtableentry when it points to a var, else
-               we are finished }
-             if pabsolutesym(p^.symtableentry)^.abstyp=tovar then
-              begin
-                p^.symtableentry:=pabsolutesym(p^.symtableentry)^.ref;
-                p^.symtable:=p^.symtableentry^.owner;
-                p^.is_absolute:=true;
-              end
-             else
-              exit;
-           end;
-         case p^.symtableentry^.typ of
-            funcretsym :
-              begin
-                p1:=genzeronode(funcretn);
-                p1^.funcretprocinfo:=pprocinfo(pfuncretsym(p^.symtableentry)^.funcretprocinfo);
-                p1^.rettype:=pfuncretsym(p^.symtableentry)^.rettype;
-                firstpass(p1);
-                { if it's refered as absolute then we need to have the
-                  type of the absolute instead of the function return,
-                  the function return is then also assigned }
-                if p^.is_absolute then
-                 begin
-                   pprocinfo(p1^.funcretprocinfo)^.funcret_state:=vs_assigned;
-                   p1^.resulttype:=p^.resulttype;
-                 end;
-                putnode(p);
-                p:=p1;
-              end;
-            constsym:
-              begin
-                 if pconstsym(p^.symtableentry)^.consttyp=constresourcestring then
-                   begin
-                      p^.resulttype:=cansistringdef;
-                      { we use ansistrings so no fast exit here }
-                      if assigned(procinfo) then
-                        procinfo^.no_fast_exit:=true;
-                      p^.location.loc:=LOC_MEM;
-                   end
-                 else
-                   internalerror(22799);
-              end;
-            varsym :
-                begin
-                { if it's refered by absolute then it's used }
-                if p^.is_absolute then
-                 pvarsym(p^.symtableentry)^.varstate:=vs_used
-                else
-                 if (p^.resulttype=nil) then
-                     p^.resulttype:=pvarsym(p^.symtableentry)^.vartype.def;
-                   if (p^.symtable^.symtabletype in [parasymtable,localsymtable]) and
-                      (lexlevel>p^.symtable^.symtablelevel) then
-                     begin
-                       { if the variable is in an other stackframe then we need
-                         a register to dereference }
-                       if (p^.symtable^.symtablelevel)>0 then
-                        begin
-                          p^.registers32:=1;
-                          { further, the variable can't be put into a register }
-                          pvarsym(p^.symtableentry)^.varoptions:=
-                            pvarsym(p^.symtableentry)^.varoptions-[vo_fpuregable,vo_regable];
-                        end;
-                     end;
-                   if (pvarsym(p^.symtableentry)^.varspez=vs_const) then
-                     p^.location.loc:=LOC_MEM;
-                   { we need a register for call by reference parameters }
-                   if (pvarsym(p^.symtableentry)^.varspez in [vs_var,vs_out]) or
-                      ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
-                      push_addr_param(pvarsym(p^.symtableentry)^.vartype.def)) or
-                      { call by value open arrays are also indirect addressed }
-                      is_open_array(pvarsym(p^.symtableentry)^.vartype.def) then
-                     p^.registers32:=1;
-                   if p^.symtable^.symtabletype=withsymtable then
-                     inc(p^.registers32);
-
-                   if ([vo_is_thread_var,vo_is_dll_var]*pvarsym(p^.symtableentry)^.varoptions)<>[] then
-                     p^.registers32:=1;
-                   { a class variable is a pointer !!!
-                     yes, but we have to resolve the reference in an
-                     appropriate tree node (FK)
-
-                   if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
-                      ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oo_is_class)<>0) then
-                     p^.registers32:=1;
-                   }
-
-                   { count variable references }
-
-                     { this will create problem with local var set by
-                     under_procedures
-                     if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym)
-                       and ((pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)
-                       or (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst))) then }
-                   if t_times<1 then
-                     inc(pvarsym(p^.symtableentry)^.refs)
-                   else
-                     inc(pvarsym(p^.symtableentry)^.refs,t_times);
-                end;
-            typedconstsym :
-                if not p^.is_absolute then
-                  p^.resulttype:=ptypedconstsym(p^.symtableentry)^.typedconsttype.def;
-            procsym :
-                begin
-                   if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
-                     CGMessage(parser_e_no_overloaded_procvars);
-                   p^.resulttype:=pprocsym(p^.symtableentry)^.definition;
-                   { if the owner of the procsym is a object,  }
-                   { left must be set, if left isn't set       }
-                   { it can be only self                       }
-                   { this code is only used in TP procvar mode }
-                   if (m_tp_procvar in aktmodeswitches) and
-                      not(assigned(p^.left)) and
-                     (pprocsym(p^.symtableentry)^.owner^.symtabletype=objectsymtable) then
-                      p^.left:=genselfnode(pobjectdef(p^.symtableentry^.owner^.defowner));
-                   { method pointer ? }
-                   if assigned(p^.left) then
-                     begin
-                        firstpass(p^.left);
-                        p^.registers32:=max(p^.registers32,p^.left^.registers32);
-                        p^.registersfpu:=max(p^.registersfpu,p^.left^.registersfpu);
- {$ifdef SUPPORT_MMX}
-                        p^.registersmmx:=max(p^.registersmmx,p^.left^.registersmmx);
- {$endif SUPPORT_MMX}
-                     end;
-                end;
-           else
-             internalerror(3);
-         end;
-      end;
-
-
-{*****************************************************************************
-                             FirstAssignment
-*****************************************************************************}
-
-    procedure firstassignment(var p : ptree);
-{$ifdef newoptimizations2}
-      var
-        hp : ptree;
-{$endif newoptimizations2}
-      begin
-         { must be made unique }
-         set_unique(p^.left);
-
-         { set we the function result? }
-         set_funcret_is_valid(p^.left);
-
-         firstpass(p^.left);
-         set_varstate(p^.left,false);
-         if codegenerror then
-           exit;
-
-         { assignements to open arrays aren't allowed }
-         if is_open_array(p^.left^.resulttype) then
-           CGMessage(type_e_mismatch);
-
-         { test if we can avoid copying string to temp
-           as in s:=s+...; (PM) }
-{$ifdef dummyi386}
-         if ((p^.right^.treetype=addn) or (p^.right^.treetype=subn)) and
-            equal_trees(p^.left,p^.right^.left) and
-            (ret_in_acc(p^.left^.resulttype)) and
-            (not cs_rangechecking in aktmoduleswitches^) then
-           begin
-              disposetree(p^.right^.left);
-              hp:=p^.right;
-              p^.right:=p^.right^.right;
-              if hp^.treetype=addn then
-                p^.assigntyp:=at_plus
-              else
-                p^.assigntyp:=at_minus;
-              putnode(hp);
-           end;
-         if p^.assigntyp<>at_normal then
-           begin
-              { for fpu type there is no faster way }
-              if is_fpu(p^.left^.resulttype) then
-                case p^.assigntyp of
-                  at_plus  : p^.right:=gennode(addn,getcopy(p^.left),p^.right);
-                  at_minus : p^.right:=gennode(subn,getcopy(p^.left),p^.right);
-                  at_star  : p^.right:=gennode(muln,getcopy(p^.left),p^.right);
-                  at_slash : p^.right:=gennode(slashn,getcopy(p^.left),p^.right);
-                end;
-           end;
-{$endif i386}
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-
-         { some string functions don't need conversion, so treat them separatly }
-         if is_shortstring(p^.left^.resulttype) and (assigned(p^.right^.resulttype)) then
-          begin
-            if not (is_shortstring(p^.right^.resulttype) or
-                    is_ansistring(p^.right^.resulttype) or
-                    is_char(p^.right^.resulttype)) then
-             begin
-               p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
-               firstpass(p^.right);
-               if codegenerror then
-                exit;
-             end;
-            { we call STRCOPY }
-            procinfo^.flags:=procinfo^.flags or pi_do_call;
-            { test for s:=s+anything ... }
-            { the problem is for
-              s:=s+s+s;
-              this is broken here !! }
-{$ifdef newoptimizations2}
-            { the above is fixed now, but still problem with s := s + f(); if }
-            { f modifies s (bad programming, so only enable if uncertain      }
-            { optimizations are on) (JM)                                      }
-            if (cs_UncertainOpts in aktglobalswitches) then
-              begin
-                hp := p^.right;
-                while hp^.treetype=addn do hp:=hp^.left;
-                if equal_trees(p^.left,hp) and
-                   not multiple_uses(p^.left,p^.right) then
-                  begin
-                    p^.concat_string:=true;
-                    hp:=p^.right;
-                    while hp^.treetype=addn do
-                      begin
-                        hp^.use_strconcat:=true;
-                        hp:=hp^.left;
-                      end;
-                  end;
-              end;
-{$endif newoptimizations2}
-          end
-         else
-          begin
-            p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
-            firstpass(p^.right);
-            if codegenerror then
-             exit;
-          end;
-
-         { test if node can be assigned, properties are allowed }
-         valid_for_assign(p^.left,true);
-
-         { check if local proc/func is assigned to procvar }
-         if p^.right^.resulttype^.deftype=procvardef then
-           test_local_to_procvar(pprocvardef(p^.right^.resulttype),p^.left^.resulttype);
-
-         p^.resulttype:=voiddef;
-         {
-           p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
-           p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
-         }
-         p^.registers32:=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;
-
-
-{*****************************************************************************
-                             FirstFuncRet
-*****************************************************************************}
-
-    procedure firstfuncret(var p : ptree);
-      begin
-         p^.resulttype:=p^.rettype.def;
-         p^.location.loc:=LOC_REFERENCE;
-         if ret_in_param(p^.rettype.def) or
-            (procinfo<>pprocinfo(p^.funcretprocinfo)) then
-           p^.registers32:=1;
-      end;
-
-
-{*****************************************************************************
-                           FirstArrayConstructRange
-*****************************************************************************}
-
-    procedure firstarrayconstructrange(var p:ptree);
-      begin
-        firstpass(p^.left);
-        set_varstate(p^.left,true);
-        firstpass(p^.right);
-        set_varstate(p^.right,true);
-        calcregisters(p,0,0,0);
-        p^.resulttype:=p^.left^.resulttype;
-      end;
-
-
-{*****************************************************************************
-                           FirstArrayConstruct
-*****************************************************************************}
-
-    procedure firstarrayconstruct(var p : ptree);
-      var
-        pd : pdef;
-        thp,
-        chp,
-        hp : ptree;
-        len : longint;
-        varia : boolean;
-      begin
-      { are we allowing array constructor? Then convert it to a set }
-        if not allow_array_constructor then
-         begin
-           arrayconstructor_to_set(p);
-           firstpass(p);
-           exit;
-         end;
-      { only pass left tree, right tree contains next construct if any }
-        pd:=p^.constructdef;
-        len:=0;
-        varia:=false;
-        if assigned(p^.left) then
-         begin
-           hp:=p;
-           while assigned(hp) do
-            begin
-              firstpass(hp^.left);
-              set_varstate(hp^.left,true);
-              if (not get_para_resulttype) and (not p^.novariaallowed) then
-               begin
-                 case hp^.left^.resulttype^.deftype of
-                   enumdef :
-                     begin
-                       hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
-                       firstpass(hp^.left);
-                     end;
-                   orddef :
-                     begin
-                       if is_integer(hp^.left^.resulttype) and
-                         not(is_64bitint(hp^.left^.resulttype)) then
-                        begin
-                          hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
-                          firstpass(hp^.left);
-                        end;
-                     end;
-                   floatdef :
-                     begin
-                       hp^.left:=gentypeconvnode(hp^.left,bestrealdef^);
-                       firstpass(hp^.left);
-                     end;
-                   stringdef :
-                     begin
-                       if p^.cargs then
-                        begin
-                          hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
-                          firstpass(hp^.left);
-                        end;
-                     end;
-                   procvardef :
-                     begin
-                       hp^.left:=gentypeconvnode(hp^.left,voidpointerdef);
-                       firstpass(hp^.left);
-                     end;
-                   pointerdef,
-                   classrefdef,
-                   objectdef : ;
-                   else
-                     CGMessagePos1(hp^.left^.fileinfo,type_e_wrong_type_in_array_constructor,hp^.left^.resulttype^.typename);
-                 end;
-               end;
-              if (pd=nil) then
-               pd:=hp^.left^.resulttype
-              else
-               begin
-                 if ((p^.novariaallowed) or (not varia)) and
-                    (not is_equal(pd,hp^.left^.resulttype)) then
-                  begin
-                    { if both should be equal try inserting a conversion }
-                    if p^.novariaallowed then
-                     begin
-                       hp^.left:=gentypeconvnode(hp^.left,pd);
-                       firstpass(hp^.left);
-                     end;
-                    varia:=true;
-                  end;
-               end;
-              inc(len);
-              hp:=hp^.right;
-            end;
-         { swap the tree for cargs }
-           if p^.cargs and (not p^.cargswap) then
-            begin
-              chp:=nil;
-              hp:=p;
-              while assigned(hp) do
-               begin
-                 thp:=hp^.right;
-                 hp^.right:=chp;
-                 chp:=hp;
-                 hp:=thp;
-               end;
-              p:=chp;
-              p^.cargs:=true;
-              p^.cargswap:=true;
-            end;
-         end;
-        calcregisters(p,0,0,0);
-        { looks a little bit dangerous to me            }
-        { len-1 gives problems with is_open_array if len=0, }
-        { is_open_array checks now for isconstructor (FK)   }
-      { if no type is set then we set the type to voiddef to overcome a
-        0 addressing }
-        if not assigned(pd) then
-         pd:=voiddef;
-      { skip if already done ! (PM) }
-        if not assigned(p^.resulttype) or
-           (p^.resulttype^.deftype<>arraydef) or
-           not parraydef(p^.resulttype)^.IsConstructor or
-           (parraydef(p^.resulttype)^.lowrange<>0) or
-           (parraydef(p^.resulttype)^.highrange<>len-1) then
-          p^.resulttype:=new(parraydef,init(0,len-1,s32bitdef));
-        parraydef(p^.resulttype)^.elementtype.def:=pd;
-        parraydef(p^.resulttype)^.IsConstructor:=true;
-        parraydef(p^.resulttype)^.IsVariant:=varia;
-        p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                                 Type
-*****************************************************************************}
-
-    procedure firsttype(var p : ptree);
-      begin
-      { do nothing, p^.resulttype is already set }
-      end;
-
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.8  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.7  2000/08/27 16:11:55  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.6  2000/08/15 03:41:27  peter
-    * previous commit was wrong file :(
-
-  Revision 1.5  2000/08/13 19:21:13  peter
-    * fix for absolute to mem address (merged)
-
-  Revision 1.4  2000/08/13 08:42:59  peter
-    * support absolute refering to funcret (merged)
-
-  Revision 1.3  2000/07/13 12:08:28  michael
-  + patched to 1.1.0 with former 1.09patch from peter
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-
-}

compiler/old/tcmat.pas

@@ -1,504 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for math nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcmat;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstmoddiv(var p : ptree);
-    procedure firstshlshr(var p : ptree);
-    procedure firstunaryminus(var p : ptree);
-    procedure firstnot(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,tokens,
-      cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      htypechk,pass_1,cpubase,cpuinfo,
-{$ifdef newcg}
-      cgbase,
-{$else newcg}
-      hcodegen,
-{$endif newcg}
-      { for isbinaryoverloaded function }
-      tcadd;
-
-{*****************************************************************************
-                             FirstModDiv
-*****************************************************************************}
-
-    procedure firstmoddiv(var p : ptree);
-      var
-         t : ptree;
-         rv,lv : tconstexprint;
-         rd,ld : pdef;
-
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-
-         if isbinaryoverloaded(p) then
-           exit;
-
-         { check for division by zero }
-         rv:=p^.right^.value;
-         lv:=p^.left^.value;
-         if is_constintnode(p^.right) and (rv=0) then
-          begin
-            Message(parser_e_division_by_zero);
-            { recover }
-            rv:=1;
-          end;
-
-         if is_constintnode(p^.left) and is_constintnode(p^.right) then
-           begin
-              case p^.treetype of
-                modn:
-                  t:=genintconstnode(lv mod rv);
-                divn:
-                  t:=genintconstnode(lv div rv);
-              end;
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-         if (p^.left^.resulttype^.deftype=orddef) and (p^.right^.resulttype^.deftype=orddef) and
-            (is_64bitint(p^.left^.resulttype) or is_64bitint(p^.right^.resulttype)) then
-           begin
-              rd:=p^.right^.resulttype;
-              ld:=p^.left^.resulttype;
-              if (porddef(rd)^.typ=s64bit) or (porddef(ld)^.typ=s64bit) then
-                begin
-                   if (porddef(ld)^.typ<>s64bit) then
-                     begin
-                       p^.left:=gentypeconvnode(p^.left,cs64bitdef);
-                       firstpass(p^.left);
-                     end;
-                   if (porddef(rd)^.typ<>s64bit) then
-                     begin
-                        p^.right:=gentypeconvnode(p^.right,cs64bitdef);
-                        firstpass(p^.right);
-                     end;
-                   calcregisters(p,2,0,0);
-                end
-              else if (porddef(rd)^.typ=u64bit) or (porddef(ld)^.typ=u64bit) then
-                begin
-                   if (porddef(ld)^.typ<>u64bit) then
-                     begin
-                       p^.left:=gentypeconvnode(p^.left,cu64bitdef);
-                       firstpass(p^.left);
-                     end;
-                   if (porddef(rd)^.typ<>u64bit) then
-                     begin
-                        p^.right:=gentypeconvnode(p^.right,cu64bitdef);
-                        firstpass(p^.right);
-                     end;
-                   calcregisters(p,2,0,0);
-                end;
-              p^.resulttype:=p^.left^.resulttype;
-           end
-         else
-           begin
-              if not(p^.right^.resulttype^.deftype=orddef) or
-                not(porddef(p^.right^.resulttype)^.typ in [s32bit,u32bit]) then
-                p^.right:=gentypeconvnode(p^.right,s32bitdef);
-
-              if not(p^.left^.resulttype^.deftype=orddef) or
-                not(porddef(p^.left^.resulttype)^.typ in [s32bit,u32bit]) then
-                p^.left:=gentypeconvnode(p^.left,s32bitdef);
-
-              firstpass(p^.left);
-              firstpass(p^.right);
-
-{$ifdef cardinalmulfix}
-{ if we divide a u32bit by a positive constant, the result is also u32bit (JM) }
-              if (p^.left^.resulttype^.deftype = orddef) and
-                 (p^.left^.resulttype^.deftype = orddef) then
-                begin
-                  if (porddef(p^.left^.resulttype)^.typ = u32bit) and
-                     is_constintnode(p^.right) and
-{                     (porddef(p^.right^.resulttype)^.typ <> u32bit) and}
-                     (p^.right^.value > 0) then
-                    begin
-                      p^.right := gentypeconvnode(p^.right,u32bitdef);
-                      firstpass(p^.right);
-                    end;
-{ adjust also the left resulttype if necessary }
-                  if (porddef(p^.right^.resulttype)^.typ = u32bit) and
-                     is_constintnode(p^.left) and
-    {                 (porddef(p^.left^.resulttype)^.typ <> u32bit) and}
-                     (p^.left^.value > 0) then
-                    begin
-                      p^.left := gentypeconvnode(p^.left,u32bitdef);
-                      firstpass(p^.left);
-                    end;
-                end;
-{$endif cardinalmulfix}
-
-              { the resulttype depends on the right side, because the left becomes }
-              { always 64 bit                                                      }
-              p^.resulttype:=p^.right^.resulttype;
-
-              if codegenerror then
-                exit;
-
-              left_right_max(p);
-              if p^.left^.registers32<=p^.right^.registers32 then
-                inc(p^.registers32);
-           end;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-{*****************************************************************************
-                             FirstShlShr
-*****************************************************************************}
-
-    procedure firstshlshr(var p : ptree);
-      var
-         t : ptree;
-         regs : longint;
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-
-         if isbinaryoverloaded(p) then
-           exit;
-
-         if is_constintnode(p^.left) and is_constintnode(p^.right) then
-           begin
-              case p^.treetype of
-                 shrn:
-                   t:=genintconstnode(p^.left^.value shr p^.right^.value);
-                 shln:
-                   t:=genintconstnode(p^.left^.value shl p^.right^.value);
-              end;
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-         { 64 bit ints have their own shift handling }
-         if not(is_64bitint(p^.left^.resulttype)) then
-           begin
-              p^.left:=gentypeconvnode(p^.left,s32bitdef);
-              firstpass(p^.left);
-              regs:=1;
-              p^.resulttype:=s32bitdef;
-           end
-         else
-           begin
-              p^.resulttype:=p^.left^.resulttype;
-              regs:=2;
-           end;
-
-         p^.right:=gentypeconvnode(p^.right,s32bitdef);
-         firstpass(p^.right);
-
-         if codegenerror then
-           exit;
-
-         if (p^.right^.treetype<>ordconstn) then
-          inc(regs);
-         calcregisters(p,regs,0,0);
-
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-{*****************************************************************************
-                             FirstUnaryMinus
-*****************************************************************************}
-
-    procedure firstunaryminus(var p : ptree);
-      var
-         t : ptree;
-         minusdef : pprocdef;
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=p^.left^.resulttype;
-         if codegenerror then
-           exit;
-         if is_constintnode(p^.left) then
-           begin
-              t:=genintconstnode(-p^.left^.value);
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-           { nasm can not cope with negativ reals !! }
-         if is_constrealnode(p^.left)
-{$ifdef i386}
-           and not(aktoutputformat in [as_i386_nasmcoff,as_i386_nasmelf,as_i386_nasmobj])
-{$endif i386}
-             then
-           begin
-              t:=genrealconstnode(-p^.left^.value_real,bestrealdef^);
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-         if (p^.left^.resulttype^.deftype=floatdef) then
-           begin
-              if pfloatdef(p^.left^.resulttype)^.typ=f32bit then
-                begin
-                   if (p^.left^.location.loc<>LOC_REGISTER) and
-                     (p^.registers32<1) then
-                     p^.registers32:=1;
-                   p^.location.loc:=LOC_REGISTER;
-                end
-              else
-                p^.location.loc:=LOC_FPU;
-           end
-{$ifdef SUPPORT_MMX}
-         else if (cs_mmx in aktlocalswitches) and
-           is_mmx_able_array(p^.left^.resulttype) then
-             begin
-               if (p^.left^.location.loc<>LOC_MMXREGISTER) and
-                 (p^.registersmmx<1) then
-                 p^.registersmmx:=1;
-               { if saturation is on, p^.left^.resulttype isn't
-                 "mmx able" (FK)
-               if (cs_mmx_saturation in aktlocalswitches^) and
-                 (porddef(parraydef(p^.resulttype)^.definition)^.typ in
-                 [s32bit,u32bit]) then
-                 CGMessage(type_e_mismatch);
-               }
-             end
-{$endif SUPPORT_MMX}
-         else if is_64bitint(p^.left^.resulttype) then
-           begin
-              firstpass(p^.left);
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-              p^.registers32:=p^.left^.registers32;
-              if codegenerror then
-                exit;
-              if (p^.left^.location.loc<>LOC_REGISTER) and
-                (p^.registers32<2) then
-              p^.registers32:=2;
-              p^.location.loc:=LOC_REGISTER;
-              p^.resulttype:=p^.left^.resulttype;
-           end
-         else if (p^.left^.resulttype^.deftype=orddef) then
-           begin
-              p^.left:=gentypeconvnode(p^.left,s32bitdef);
-              firstpass(p^.left);
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-              p^.registers32:=p^.left^.registers32;
-              if codegenerror then
-                exit;
-              if (p^.left^.location.loc<>LOC_REGISTER) and
-                (p^.registers32<1) then
-              p^.registers32:=1;
-              p^.location.loc:=LOC_REGISTER;
-              p^.resulttype:=p^.left^.resulttype;
-           end
-         else
-           begin
-              if assigned(overloaded_operators[_minus]) then
-                minusdef:=overloaded_operators[_minus]^.definition
-              else
-                minusdef:=nil;
-              while assigned(minusdef) do
-                begin
-                   if is_equal(pparaitem(minusdef^.para^.first)^.paratype.def,p^.left^.resulttype) and
-                      (pparaitem(minusdef^.para^.first)^.next=nil) then
-                     begin
-                        t:=gencallnode(overloaded_operators[_minus],nil);
-                        t^.left:=gencallparanode(p^.left,nil);
-                        putnode(p);
-                        p:=t;
-                        firstpass(p);
-                        exit;
-                     end;
-                   minusdef:=minusdef^.nextoverloaded;
-                end;
-              CGMessage(type_e_mismatch);
-           end;
-      end;
-
-
-{*****************************************************************************
-                               FirstNot
-*****************************************************************************}
-
-    procedure firstnot(var p : ptree);
-      var
-         t : ptree;
-         notdef : pprocdef;
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           exit;
-
-         if (p^.left^.treetype=ordconstn) then
-           begin
-              if is_boolean(p^.left^.resulttype) then
-                { here we do a boolena(byte(..)) type cast because }
-                { boolean(<int64>) is buggy in 1.00                }
-                t:=genordinalconstnode(byte(not(boolean(byte(p^.left^.value)))),p^.left^.resulttype)
-              else
-                t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
-              disposetree(p);
-              firstpass(t);
-              p:=t;
-              exit;
-           end;
-         p^.resulttype:=p^.left^.resulttype;
-         p^.location.loc:=p^.left^.location.loc;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         if is_boolean(p^.resulttype) then
-           begin
-             p^.registers32:=p^.left^.registers32;
-             if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-              begin
-                p^.location.loc:=LOC_REGISTER;
-                if (p^.registers32<1) then
-                 p^.registers32:=1;
-              end;
-            { before loading it into flags we need to load it into
-              a register thus 1 register is need PM }
-{$ifdef i386}
-             if p^.left^.location.loc<>LOC_JUMP then
-               p^.location.loc:=LOC_FLAGS;
-{$endif def i386}
-           end
-         else
-{$ifdef SUPPORT_MMX}
-           if (cs_mmx in aktlocalswitches) and
-             is_mmx_able_array(p^.left^.resulttype) then
-             begin
-               if (p^.left^.location.loc<>LOC_MMXREGISTER) and
-                 (p^.registersmmx<1) then
-                 p^.registersmmx:=1;
-             end
-         else
-{$endif SUPPORT_MMX}
-           if is_64bitint(p^.left^.resulttype) then
-             begin
-                p^.registers32:=p^.left^.registers32;
-                if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
-                 begin
-                   p^.location.loc:=LOC_REGISTER;
-                   if (p^.registers32<2) then
-                    p^.registers32:=2;
-                 end;
-             end
-         else if is_integer(p^.left^.resulttype) then
-           begin
-              p^.left:=gentypeconvnode(p^.left,s32bitdef);
-              firstpass(p^.left);
-              if codegenerror then
-                exit;
-
-              p^.resulttype:=p^.left^.resulttype;
-              p^.registers32:=p^.left^.registers32;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-              if (p^.left^.location.loc<>LOC_REGISTER) and
-                 (p^.registers32<1) then
-                p^.registers32:=1;
-              p^.location.loc:=LOC_REGISTER;
-           end
-         else
-           begin
-              if assigned(overloaded_operators[_op_not]) then
-                notdef:=overloaded_operators[_op_not]^.definition
-              else
-                notdef:=nil;
-              while assigned(notdef) do
-                begin
-                   if is_equal(pparaitem(notdef^.para^.first)^.paratype.def,p^.left^.resulttype) and
-                      (pparaitem(notdef^.para^.first)^.next=nil) then
-                     begin
-                        t:=gencallnode(overloaded_operators[_op_not],nil);
-                        t^.left:=gencallparanode(p^.left,nil);
-                        putnode(p);
-                        p:=t;
-                        firstpass(p);
-                        exit;
-                     end;
-                   notdef:=notdef^.nextoverloaded;
-                end;
-              CGMessage(type_e_mismatch);
-           end;
-
-         p^.registersfpu:=p^.left^.registersfpu;
-      end;
-
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.5  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.4  2000/08/17 12:03:48  florian
-    * fixed several problems with the int64 constants
-
-  Revision 1.3  2000/08/16 13:06:07  florian
-    + support of 64 bit integer constants
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-
-}

compiler/old/tcmem.pas

@@ -1,675 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for memory related nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcmem;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstloadvmt(var p : ptree);
-    procedure firsthnew(var p : ptree);
-    procedure firstnew(var p : ptree);
-    procedure firsthdispose(var p : ptree);
-    procedure firstsimplenewdispose(var p : ptree);
-    procedure firstaddr(var p : ptree);
-    procedure firstdoubleaddr(var p : ptree);
-    procedure firstderef(var p : ptree);
-    procedure firstsubscript(var p : ptree);
-    procedure firstvec(var p : ptree);
-    procedure firstself(var p : ptree);
-    procedure firstwith(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cutils,cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      htypechk,pass_1,cpubase
-{$ifdef newcg}
-      ,cgbase
-{$else newcg}
-      ,hcodegen
-{$endif newcg}
-      ;
-{*****************************************************************************
-                            FirstLoadVMT
-*****************************************************************************}
-
-    procedure firstloadvmt(var p : ptree);
-      begin
-         p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-{*****************************************************************************
-                             FirstHNew
-*****************************************************************************}
-
-    procedure firsthnew(var p : ptree);
-      begin
-      end;
-
-
-{*****************************************************************************
-                             FirstNewN
-*****************************************************************************}
-
-    procedure firstnew(var p : ptree);
-      begin
-         { Standardeinleitung }
-         if assigned(p^.left) then
-           firstpass(p^.left);
-
-         if codegenerror then
-           exit;
-         if assigned(p^.left) then
-           begin
-              p^.registers32:=p^.left^.registers32;
-              p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-         { result type is already set }
-         procinfo^.flags:=procinfo^.flags or pi_do_call;
-         if assigned(p^.left) then
-           p^.location.loc:=LOC_REGISTER
-         else
-           p^.location.loc:=LOC_REFERENCE;
-      end;
-
-
-{*****************************************************************************
-                            FirstDispose
-*****************************************************************************}
-
-    procedure firsthdispose(var p : ptree);
-      begin
-         firstpass(p^.left);
-
-         if codegenerror then
-           exit;
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         {
-         if p^.left^.location.loc<>LOC_REFERENCE then
-           CGMessage(cg_e_illegal_expression);
-         }
-         if p^.left^.location.loc=LOC_CREGISTER then
-           inc(p^.registers32);
-         p^.location.loc:=LOC_REFERENCE;
-         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
-      end;
-
-
-{*****************************************************************************
-                        FirstSimpleNewDispose
-*****************************************************************************}
-
-    procedure firstsimplenewdispose(var p : ptree);
-      begin
-         { this cannot be in a register !! }
-         make_not_regable(p^.left);
-
-         firstpass(p^.left);
-         if codegenerror then
-          exit;
-
-         { check the type }
-         if p^.left^.resulttype=nil then
-          p^.left^.resulttype:=generrordef;
-         if (p^.left^.resulttype^.deftype<>pointerdef) then
-           CGMessage1(type_e_pointer_type_expected,p^.left^.resulttype^.typename);
-
-         if (p^.left^.location.loc<>LOC_REFERENCE) {and
-            (p^.left^.location.loc<>LOC_CREGISTER)} then
-           CGMessage(cg_e_illegal_expression);
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=voiddef;
-         procinfo^.flags:=procinfo^.flags or pi_do_call;
-      end;
-
-
-{*****************************************************************************
-                             FirstAddr
-*****************************************************************************}
-
-    procedure firstaddr(var p : ptree);
-      var
-         hp  : ptree;
-         hp2 : pparaitem;
-         hp3 : pabstractprocdef;
-      begin
-         make_not_regable(p^.left);
-         if not(assigned(p^.resulttype)) then
-           begin
-              { tp @procvar support (type of @procvar is a void pointer)
-                Note: we need to leave the addrn in the tree,
-                else we can't see the difference between @procvar and procvar.
-                we set the procvarload flag so a secondpass does nothing for
-                this node (PFV) }
-              if (m_tp_procvar in aktmodeswitches) then
-               begin
-                 hp:=p^.left;
-                 case hp^.treetype of
-                   calln :
-                     begin
-                       { is it a procvar? }
-                       hp:=hp^.right;
-                       if assigned(hp) then
-                         begin
-                           { remove calln node }
-                           putnode(p^.left);
-                           p^.left:=hp;
-                           firstpass(hp);
-                           p^.procvarload:=true;
-                         end;
-                     end;
-                   loadn,
-                   subscriptn,
-                   typeconvn,
-                   vecn,
-                   derefn :
-                     begin
-                       firstpass(hp);
-                       if codegenerror then
-                        exit;
-                       if hp^.resulttype^.deftype=procvardef then
-                        begin
-                          p^.procvarload:=true;
-                        end;
-                     end;
-                 end;
-               end;
-              if p^.procvarload then
-               begin
-                 p^.registers32:=p^.left^.registers32;
-                 p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-                 p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-                 if p^.registers32<1 then
-                   p^.registers32:=1;
-                 p^.location.loc:=p^.left^.location.loc;
-                 p^.resulttype:=voidpointerdef;
-                 exit;
-               end;
-
-              { proc 2 procvar ? }
-              if p^.left^.treetype=calln then
-                begin
-                  { generate a methodcallnode or proccallnode }
-                  { we shouldn't convert things like @tcollection.load }
-                  if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                    not(assigned(p^.left^.methodpointer) and (p^.left^.methodpointer^.treetype=typen)) then
-                   begin
-                     hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc,
-                       getcopy(p^.left^.methodpointer));
-                     disposetree(p);
-                     firstpass(hp);
-                     p:=hp;
-                     exit;
-                   end
-                  else
-                   hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
-
-                  { result is a procedure variable }
-                  { No, to be TP compatible, you must return a pointer to
-                    the procedure that is stored in the procvar.}
-                  if not(m_tp_procvar in aktmodeswitches) then
-                    begin
-                       p^.resulttype:=new(pprocvardef,init);
-
-                    { it could also be a procvar, not only pprocsym ! }
-                       if p^.left^.symtableprocentry^.typ=varsym then
-                        hp3:=pabstractprocdef(pvarsym(p^.left^.symtableentry)^.vartype.def)
-                       else
-                        hp3:=pabstractprocdef(pprocsym(p^.left^.symtableprocentry)^.definition);
-
-                       pprocvardef(p^.resulttype)^.proctypeoption:=hp3^.proctypeoption;
-                       pprocvardef(p^.resulttype)^.proccalloptions:=hp3^.proccalloptions;
-                       pprocvardef(p^.resulttype)^.procoptions:=hp3^.procoptions;
-                       pprocvardef(p^.resulttype)^.rettype:=hp3^.rettype;
-                       pprocvardef(p^.resulttype)^.symtablelevel:=hp3^.symtablelevel;
-
-                     { method ? then set the methodpointer flag }
-                       if (hp3^.owner^.symtabletype=objectsymtable) and
-                          (pobjectdef(hp3^.owner^.defowner)^.is_class) then
-                         include(pprocvardef(p^.resulttype)^.procoptions,po_methodpointer);
-                       { we need to process the parameters reverse so they are inserted
-                         in the correct right2left order (PFV) }
-                       hp2:=pparaitem(hp3^.para^.last);
-                       while assigned(hp2) do
-                         begin
-                            pprocvardef(p^.resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp,hp2^.defaultvalue);
-                            hp2:=pparaitem(hp2^.previous);
-                         end;
-                    end
-                  else
-                    p^.resulttype:=voidpointerdef;
-
-                  disposetree(p^.left);
-                  p^.left:=hp;
-                end
-              else
-                begin
-                  firstpass(p^.left);
-                  { what are we getting the address from an absolute sym? }
-                  hp:=p^.left;
-                  while assigned(hp) and (hp^.treetype in [vecn,derefn,subscriptn]) do
-                   hp:=hp^.left;
-                  if assigned(hp) and (hp^.treetype=loadn) and
-                     ((hp^.symtableentry^.typ=absolutesym) and
-                      pabsolutesym(hp^.symtableentry)^.absseg) then
-                   begin
-                     if not(cs_typed_addresses in aktlocalswitches) then
-                       p^.resulttype:=voidfarpointerdef
-                     else
-                       p^.resulttype:=new(ppointerdef,initfardef(p^.left^.resulttype));
-                   end
-                  else
-                   begin
-                     if not(cs_typed_addresses in aktlocalswitches) then
-                       p^.resulttype:=voidpointerdef
-                     else
-                       p^.resulttype:=new(ppointerdef,initdef(p^.left^.resulttype));
-                   end;
-                end;
-           end;
-         firstpass(p^.left);
-         { this is like the function addr }
-         inc(parsing_para_level);
-         set_varstate(p^.left,false);
-         dec(parsing_para_level);
-         if codegenerror then
-           exit;
-
-         { don't allow constants }
-         if is_constnode(p^.left) then
-          begin
-            aktfilepos:=p^.left^.fileinfo;
-            CGMessage(type_e_no_addr_of_constant);
-          end
-         else
-           begin
-             { we should allow loc_mem for @string }
-             if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
-               begin
-                 aktfilepos:=p^.left^.fileinfo;
-                 CGMessage(cg_e_illegal_expression);
-               end;
-           end;
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         { is this right for object of methods ?? }
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-{*****************************************************************************
-                           FirstDoubleAddr
-*****************************************************************************}
-
-    procedure firstdoubleaddr(var p : ptree);
-      begin
-         make_not_regable(p^.left);
-         firstpass(p^.left);
-         inc(parsing_para_level);
-         set_varstate(p^.left,false);
-         dec(parsing_para_level);
-         if p^.resulttype=nil then
-           p^.resulttype:=voidpointerdef;
-         if codegenerror then
-           exit;
-
-         if (p^.left^.resulttype^.deftype)<>procvardef then
-           CGMessage(cg_e_illegal_expression);
-
-         if (p^.left^.location.loc<>LOC_REFERENCE) then
-           CGMessage(cg_e_illegal_expression);
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         if p^.registers32<1 then
-           p^.registers32:=1;
-         p^.location.loc:=LOC_REGISTER;
-      end;
-
-
-{*****************************************************************************
-                             FirstDeRef
-*****************************************************************************}
-
-    procedure firstderef(var p : ptree);
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           begin
-             p^.resulttype:=generrordef;
-             exit;
-           end;
-
-         p^.registers32:=max(p^.left^.registers32,1);
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-         if p^.left^.resulttype^.deftype<>pointerdef then
-          CGMessage(cg_e_invalid_qualifier);
-
-         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
-         p^.location.loc:=LOC_REFERENCE;
-      end;
-
-
-{*****************************************************************************
-                            FirstSubScript
-*****************************************************************************}
-
-    procedure firstsubscript(var p : ptree);
-      begin
-         firstpass(p^.left);
-         if codegenerror then
-           begin
-             p^.resulttype:=generrordef;
-             exit;
-           end;
-         p^.resulttype:=p^.vs^.vartype.def;
-
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-         { classes must be dereferenced implicit }
-         if (p^.left^.resulttype^.deftype=objectdef) and
-           pobjectdef(p^.left^.resulttype)^.is_class then
-           begin
-              if p^.registers32=0 then
-                p^.registers32:=1;
-              p^.location.loc:=LOC_REFERENCE;
-           end
-         else
-           begin
-              if (p^.left^.location.loc<>LOC_MEM) and
-                (p^.left^.location.loc<>LOC_REFERENCE) then
-                CGMessage(cg_e_illegal_expression);
-              set_location(p^.location,p^.left^.location);
-           end;
-      end;
-
-
-{*****************************************************************************
-                               FirstVec
-*****************************************************************************}
-
-    procedure firstvec(var p : ptree);
-      var
-         harr : pdef;
-         ct : tconverttype;
-{$ifdef consteval}
-         tcsym : ptypedconstsym;
-{$endif}
-      begin
-         firstpass(p^.left);
-         firstpass(p^.right);
-         if codegenerror then
-           exit;
-
-         { range check only for arrays }
-         if (p^.left^.resulttype^.deftype=arraydef) then
-           begin
-              if (isconvertable(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def,
-                    ct,ordconstn,false)=0) and
-                 not(is_equal(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def)) then
-                CGMessage(type_e_mismatch);
-           end;
-         { Never convert a boolean or a char !}
-         { maybe type conversion }
-         if (p^.right^.resulttype^.deftype<>enumdef) and
-            not(is_char(p^.right^.resulttype)) and
-            not(is_boolean(p^.right^.resulttype)) then
-           begin
-             p^.right:=gentypeconvnode(p^.right,s32bitdef);
-             firstpass(p^.right);
-             if codegenerror then
-              exit;
-           end;
-
-         { are we accessing a pointer[], then convert the pointer to
-           an array first, in FPC this is allowed for all pointers in
-           delphi/tp7 it's only allowed for pchars }
-         if (p^.left^.resulttype^.deftype=pointerdef) and
-            ((m_fpc in aktmodeswitches) or
-             is_pchar(p^.left^.resulttype)) then
-          begin
-            { convert pointer to array }
-            harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
-            parraydef(harr)^.elementtype.def:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
-            p^.left:=gentypeconvnode(p^.left,harr);
-            firstpass(p^.left);
-            if codegenerror then
-             exit;
-            p^.resulttype:=parraydef(harr)^.elementtype.def
-          end;
-
-         { determine return type }
-         if not assigned(p^.resulttype) then
-           if p^.left^.resulttype^.deftype=arraydef then
-             p^.resulttype:=parraydef(p^.left^.resulttype)^.elementtype.def
-           else if p^.left^.resulttype^.deftype=stringdef then
-             begin
-                { indexed access to strings }
-                case pstringdef(p^.left^.resulttype)^.string_typ of
-                   {
-                   st_widestring : p^.resulttype:=cwchardef;
-                   }
-                   st_ansistring : p^.resulttype:=cchardef;
-                   st_longstring : p^.resulttype:=cchardef;
-                   st_shortstring : p^.resulttype:=cchardef;
-                end;
-             end
-           else
-             CGMessage(type_e_array_required);
-
-         { the register calculation is easy if a const index is used }
-         if p^.right^.treetype=ordconstn then
-           begin
-{$ifdef consteval}
-              { constant evaluation }
-              if (p^.left^.treetype=loadn) and
-                 (p^.left^.symtableentry^.typ=typedconstsym) then
-               begin
-                 tcsym:=ptypedconstsym(p^.left^.symtableentry);
-                 if tcsym^.defintion^.typ=stringdef then
-                  begin
-
-                  end;
-               end;
-{$endif}
-              p^.registers32:=p^.left^.registers32;
-
-              { for ansi/wide strings, we need at least one register }
-              if is_ansistring(p^.left^.resulttype) or
-                is_widestring(p^.left^.resulttype) then
-                p^.registers32:=max(p^.registers32,1);
-           end
-         else
-           begin
-              { this rules are suboptimal, but they should give }
-              { good results                                }
-              p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
-
-              { for ansi/wide strings, we need at least one register }
-              if is_ansistring(p^.left^.resulttype) or
-                is_widestring(p^.left^.resulttype) then
-                p^.registers32:=max(p^.registers32,1);
-
-              { need we an extra register when doing the restore ? }
-              if (p^.left^.registers32<=p^.right^.registers32) and
-              { only if the node needs less than 3 registers }
-              { two for the right node and one for the       }
-              { left address                             }
-                (p^.registers32<3) then
-                inc(p^.registers32);
-
-              { need we an extra register for the index ? }
-              if (p^.right^.location.loc<>LOC_REGISTER)
-              { only if the right node doesn't need a register }
-                and (p^.right^.registers32<1) then
-                inc(p^.registers32);
-
-              { not correct, but what works better ?
-              if p^.left^.registers32>0 then
-                p^.registers32:=max(p^.registers32,2)
-              else
-                 min. one register
-                p^.registers32:=max(p^.registers32,1);
-              }
-           end;
-         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^.left^.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
-           p^.location.loc:=LOC_REFERENCE
-         else
-           p^.location.loc:=LOC_MEM;
-      end;
-
-
-{*****************************************************************************
-                               FirstSelf
-*****************************************************************************}
-
-    procedure firstself(var p : ptree);
-      begin
-         if (p^.resulttype^.deftype=classrefdef) or
-           ((p^.resulttype^.deftype=objectdef)
-             and pobjectdef(p^.resulttype)^.is_class
-           ) then
-           p^.location.loc:=LOC_CREGISTER
-         else
-           p^.location.loc:=LOC_REFERENCE;
-      end;
-
-
-{*****************************************************************************
-                               FirstWithN
-*****************************************************************************}
-
-    procedure firstwith(var p : ptree);
-      var
-         symtable : pwithsymtable;
-         i : longint;
-      begin
-         if assigned(p^.left) and assigned(p^.right) then
-            begin
-               firstpass(p^.left);
-               unset_varstate(p^.left);
-               set_varstate(p^.left,true);
-               if codegenerror then
-                 exit;
-               symtable:=p^.withsymtable;
-               for i:=1 to p^.tablecount do
-                 begin
-                    if (p^.left^.treetype=loadn) and
-                       (p^.left^.symtable=aktprocsym^.definition^.localst) then
-                      symtable^.direct_with:=true;
-                    symtable^.withnode:=p;
-                    symtable:=pwithsymtable(symtable^.next);
-                  end;
-               firstpass(p^.right);
-               if codegenerror then
-                 exit;
-
-               left_right_max(p);
-               p^.resulttype:=voiddef;
-            end
-         else
-           begin
-              { optimization }
-              disposetree(p);
-              p:=nil;
-           end;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.8  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.7  2000/08/27 16:11:55  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.6  2000/08/20 15:05:45  peter
-    * don't allow pointer indexing in non-fpc modes
-    * array type required message instead of type mismatch (merged)
-
-  Revision 1.5  2000/08/04 22:00:52  peter
-    * merges from fixes
-
-  Revision 1.4  2000/08/02 19:49:59  peter
-    * first things for default parameters
-
-  Revision 1.3  2000/07/13 12:08:28  michael
-  + patched to 1.1.0 with former 1.09patch from peter
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-
-}

compiler/old/tcset.pas

@@ -1,344 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    Type checking and register allocation for set/case nodes
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tcset;
-
-{$i defines.inc}
-
-interface
-
-    uses
-      tree;
-
-    procedure firstsetelement(var p : ptree);
-    procedure firstin(var p : ptree);
-    procedure firstrange(var p : ptree);
-    procedure firstcase(var p : ptree);
-
-
-implementation
-
-    uses
-      globtype,systems,
-      cobjects,verbose,globals,
-      symconst,symtable,aasm,types,
-      htypechk,pass_1,
-      tccnv,cpubase
-{$ifdef newcg}
-      ,cgbase
-      ,tgcpu
-{$else newcg}
-      ,hcodegen
-{$ifdef i386}
-      ,tgeni386
-{$endif}
-{$ifdef m68k}
-      ,tgen68k
-{$endif}
-{$endif newcg}
-      ;
-
-{*****************************************************************************
-                           FirstSetElement
-*****************************************************************************}
-
-    procedure firstsetelement(var p : ptree);
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-          exit;
-
-         if assigned(p^.right) then
-          begin
-            firstpass(p^.right);
-            if codegenerror then
-             exit;
-          end;
-
-         calcregisters(p,0,0,0);
-         p^.resulttype:=p^.left^.resulttype;
-         set_location(p^.location,p^.left^.location);
-      end;
-
-
-{*****************************************************************************
-                              FirstIn
-*****************************************************************************}
-
-    procedure firstin(var p : ptree);
-      type
-        byteset = set of byte;
-      var
-        t : ptree;
-        pst : pconstset;
-
-    function createsetconst(psd : psetdef) : pconstset;
-      var
-        pcs : pconstset;
-        pes : penumsym;
-        i : longint;
-      begin
-        new(pcs);
-        case psd^.elementtype.def^.deftype of
-          enumdef :
-            begin
-              pes:=penumdef(psd^.elementtype.def)^.firstenum;
-              while assigned(pes) do
-                begin
-                  pcs^[pes^.value div 8]:=pcs^[pes^.value div 8] or (1 shl (pes^.value mod 8));
-                  pes:=pes^.nextenum;
-                end;
-            end;
-          orddef :
-            begin
-              for i:=porddef(psd^.elementtype.def)^.low to porddef(psd^.elementtype.def)^.high do
-                begin
-                  pcs^[i div 8]:=pcs^[i div 8] or (1 shl (i mod 8));
-                end;
-            end;
-        end;
-       createsetconst:=pcs;
-      end;
-
-      begin
-         p^.location.loc:=LOC_FLAGS;
-         p^.resulttype:=booldef;
-
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-          exit;
-
-         { Convert array constructor first to set }
-         if is_array_constructor(p^.right^.resulttype) then
-          begin
-            arrayconstructor_to_set(p^.right);
-            firstpass(p^.right);
-            if codegenerror then
-             exit;
-          end;
-
-         { if p^.right is a typen then the def
-         is in typenodetype PM }
-         if p^.right^.treetype=typen then
-           p^.right^.resulttype:=p^.right^.typenodetype;
-
-         if p^.right^.resulttype^.deftype<>setdef then
-           CGMessage(sym_e_set_expected);
-         if codegenerror then
-           exit;
-
-         if (p^.right^.treetype=typen) then
-           begin
-             { we need to create a setconstn }
-             pst:=createsetconst(psetdef(p^.right^.typenodetype));
-             t:=gensetconstnode(pst,psetdef(p^.right^.typenodetype));
-             dispose(pst);
-             putnode(p^.right);
-             p^.right:=t;
-           end;
-
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           exit;
-
-         { empty set then return false }
-         if not assigned(psetdef(p^.right^.resulttype)^.elementtype.def) then
-          begin
-            t:=genordinalconstnode(0,booldef);
-            disposetree(p);
-            firstpass(t);
-            p:=t;
-            exit;
-          end;
-
-         { type conversion/check }
-         p^.left:=gentypeconvnode(p^.left,psetdef(p^.right^.resulttype)^.elementtype.def);
-         firstpass(p^.left);
-         if codegenerror then
-           exit;
-
-         { constant evaulation }
-         if (p^.left^.treetype=ordconstn) and (p^.right^.treetype=setconstn) then
-          begin
-            t:=genordinalconstnode(byte(p^.left^.value in byteset(p^.right^.value_set^)),booldef);
-            disposetree(p);
-            firstpass(t);
-            p:=t;
-            exit;
-          end;
-
-         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
-           procinfo^.flags:=procinfo^.flags or pi_do_call
-         else
-           begin
-              { a smallset needs maybe an misc. register }
-              if (p^.left^.treetype<>ordconstn) and
-                not(p^.right^.location.loc in [LOC_CREGISTER,LOC_REGISTER]) and
-                (p^.right^.registers32<1) then
-                inc(p^.registers32);
-           end;
-      end;
-
-
-{*****************************************************************************
-                              FirstRange
-*****************************************************************************}
-
-    procedure firstrange(var p : ptree);
-      var
-         ct : tconverttype;
-      begin
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         firstpass(p^.right);
-         set_varstate(p^.right,true);
-         if codegenerror then
-           exit;
-         { both types must be compatible }
-         if not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) and
-            (isconvertable(p^.left^.resulttype,p^.right^.resulttype,ct,ordconstn,false)=0) then
-           CGMessage(type_e_mismatch);
-         { Check if only when its a constant set }
-         if (p^.left^.treetype=ordconstn) and (p^.right^.treetype=ordconstn) then
-          begin
-          { upper limit must be greater or equal than lower limit }
-          { not if u32bit }
-            if (p^.left^.value>p^.right^.value) and
-               (( p^.left^.value<0) or (p^.right^.value>=0)) then
-              CGMessage(cg_e_upper_lower_than_lower);
-          end;
-        left_right_max(p);
-        p^.resulttype:=p^.left^.resulttype;
-        set_location(p^.location,p^.left^.location);
-      end;
-
-
-{*****************************************************************************
-                              FirstCase
-*****************************************************************************}
-
-    procedure firstcase(var p : ptree);
-      var
-         old_t_times : longint;
-         hp : ptree;
-      begin
-         { evalutes the case expression }
-{$ifdef newcg}
-         tg.cleartempgen;
-{$else newcg}
-         cleartempgen;
-{$endif newcg}
-         firstpass(p^.left);
-         set_varstate(p^.left,true);
-         if codegenerror then
-           exit;
-         p^.registers32:=p^.left^.registers32;
-         p^.registersfpu:=p^.left^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=p^.left^.registersmmx;
-{$endif SUPPORT_MMX}
-
-         { walk through all instructions }
-
-         {   estimates the repeat of each instruction }
-         old_t_times:=t_times;
-         if not(cs_littlesize in aktglobalswitches) then
-           begin
-              t_times:=t_times div case_count_labels(p^.nodes);
-              if t_times<1 then
-                t_times:=1;
-           end;
-         {   first case }
-         hp:=p^.right;
-         while assigned(hp) do
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(hp^.right);
-
-              { searchs max registers }
-              if hp^.right^.registers32>p^.registers32 then
-                p^.registers32:=hp^.right^.registers32;
-              if hp^.right^.registersfpu>p^.registersfpu then
-                p^.registersfpu:=hp^.right^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if hp^.right^.registersmmx>p^.registersmmx then
-                p^.registersmmx:=hp^.right^.registersmmx;
-{$endif SUPPORT_MMX}
-
-              hp:=hp^.left;
-           end;
-
-         { may be handle else tree }
-         if assigned(p^.elseblock) then
-           begin
-{$ifdef newcg}
-              tg.cleartempgen;
-{$else newcg}
-              cleartempgen;
-{$endif newcg}
-              firstpass(p^.elseblock);
-              if codegenerror then
-                exit;
-              if p^.registers32<p^.elseblock^.registers32 then
-                p^.registers32:=p^.elseblock^.registers32;
-              if p^.registersfpu<p^.elseblock^.registersfpu then
-                p^.registersfpu:=p^.elseblock^.registersfpu;
-{$ifdef SUPPORT_MMX}
-              if p^.registersmmx<p^.elseblock^.registersmmx then
-                p^.registersmmx:=p^.elseblock^.registersmmx;
-{$endif SUPPORT_MMX}
-           end;
-         t_times:=old_t_times;
-
-         { there is one register required for the case expression    }
-         { for 64 bit ints we cheat: the high dword is stored in EDI }
-         { so we don't need an extra register                        }
-         if p^.registers32<1 then p^.registers32:=1;
-      end;
-
-
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.4  2000/09/24 21:19:53  peter
-    * delphi compile fixes
-
-  Revision 1.3  2000/08/12 06:46:26  florian
-    + case statement for int64/qword implemented
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-
-}

compiler/old/tree.pas

@@ -1,2017 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Florian Klaempfl
-
-    This units exports some routines to manage the parse tree
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit tree;
-
-{$i defines.inc}
-
-  interface
-
-    uses
-       globtype,cobjects,cpuinfo
-       {$IFDEF NEWST}
-       ,objects,symtable,symbols,defs
-       {$ELSE}
-       ,symconst,symtable
-       {$ENDIF NEWST}
-       ,aasm,cpubase;
-
-    type
-       pconstset = ^tconstset;
-       tconstset = array[0..31] of byte;
-
-       ttreetyp = (
-          addn,     {Represents the + operator.}
-          muln,     {Represents the * operator.}
-          subn,     {Represents the - operator.}
-          divn,     {Represents the div operator.}
-          symdifn,       {Represents the >< operator.}
-          modn,     {Represents the mod operator.}
-          assignn,       {Represents an assignment.}
-          loadn,           {Represents the use of a variabele.}
-          rangen,         {Represents a range (i.e. 0..9).}
-          ltn,       {Represents the < operator.}
-          lten,     {Represents the <= operator.}
-          gtn,       {Represents the > operator.}
-          gten,     {Represents the >= operator.}
-          equaln,         {Represents the = operator.}
-          unequaln,     {Represents the <> operator.}
-          inn,       {Represents the in operator.}
-          orn,       {Represents the or operator.}
-          xorn,     {Represents the xor operator.}
-          shrn,     {Represents the shr operator.}
-          shln,     {Represents the shl operator.}
-          slashn,         {Represents the / operator.}
-          andn,     {Represents the and operator.}
-          subscriptn,      {??? Field in a record/object?}
-          derefn,         {Dereferences a pointer.}
-          addrn,           {Represents the @ operator.}
-          doubleaddrn,     {Represents the @@ operator.}
-          ordconstn,       {Represents an ordinal value.}
-          typeconvn,       {Represents type-conversion/typecast.}
-          calln,           {Represents a call node.}
-          callparan,       {Represents a parameter.}
-          realconstn,      {Represents a real value.}
-          fixconstn,       {Represents a fixed value.}
-          unaryminusn,     {Represents a sign change (i.e. -2).}
-          asmn,     {Represents an assembler node }
-          vecn,     {Represents array indexing.}
-          pointerconstn,
-          stringconstn,    {Represents a string constant.}
-          funcretn,     {Represents the function result var.}
-          selfn,           {Represents the self parameter.}
-          notn,     {Represents the not operator.}
-          inlinen,       {Internal procedures (i.e. writeln).}
-          niln,     {Represents the nil pointer.}
-          errorn,         {This part of the tree could not be
-                            parsed because of a compiler error.}
-          typen,           {A type name. Used for i.e. typeof(obj).}
-          hnewn,           {The new operation, constructor call.}
-          hdisposen,       {The dispose operation with destructor call.}
-          newn,     {The new operation, constructor call.}
-          simpledisposen,  {The dispose operation.}
-          setelementn,     {A set element(s) (i.e. [a,b] and also [a..b]).}
-          setconstn,       {A set constant (i.e. [1,2]).}
-          blockn,         {A block of statements.}
-          statementn,      {One statement in a block of nodes.}
-          loopn,           { used in genloopnode, must be converted }
-          ifn,       {An if statement.}
-          breakn,         {A break statement.}
-          continuen,       {A continue statement.}
-          repeatn,       {A repeat until block.}
-          whilen,         {A while do statement.}
-          forn,     {A for loop.}
-          exitn,           {An exit statement.}
-          withn,           {A with statement.}
-          casen,           {A case statement.}
-          labeln,         {A label.}
-          goton,           {A goto statement.}
-          simplenewn,      {The new operation.}
-          tryexceptn,      {A try except block.}
-          raisen,         {A raise statement.}
-          switchesn,       {??? Currently unused...}
-          tryfinallyn,     {A try finally statement.}
-          onn,       { for an on statement in exception code }
-          isn,       {Represents the is operator.}
-          asn,       {Represents the as typecast.}
-          caretn,         {Represents the ^ operator.}
-          failn,           {Represents the fail statement.}
-          starstarn,       {Represents the ** operator exponentiation }
-          procinlinen,     {Procedures that can be inlined }
-          arrayconstructn, {Construction node for [...] parsing}
-          arrayconstructrangen, {Range element to allow sets in array construction tree}
-          { added for optimizations where we cannot suppress }
-          nothingn,
-          loadvmtn
-       );
-
-       tconverttype = (
-          tc_equal,
-          tc_not_possible,
-          tc_string_2_string,
-          tc_char_2_string,
-          tc_pchar_2_string,
-          tc_cchar_2_pchar,
-          tc_cstring_2_pchar,
-          tc_ansistring_2_pchar,
-          tc_string_2_chararray,
-          tc_chararray_2_string,
-          tc_array_2_pointer,
-          tc_pointer_2_array,
-          tc_int_2_int,
-          tc_int_2_bool,
-          tc_bool_2_bool,
-          tc_bool_2_int,
-          tc_real_2_real,
-          tc_int_2_real,
-          tc_int_2_fix,
-          tc_real_2_fix,
-          tc_fix_2_real,
-          tc_proc_2_procvar,
-          tc_arrayconstructor_2_set,
-          tc_load_smallset,
-          tc_cord_2_pointer
-       );
-
-       { allows to determine which elementes are to be replaced }
-       tdisposetyp = (dt_nothing,dt_leftright,dt_left,dt_leftrighthigh,
-                      dt_mbleft,dt_typeconv,dt_inlinen,dt_leftrightmethod,
-                      dt_mbleft_and_method,dt_loop,dt_case,dt_with,dt_onn,
-                      dt_leftrightframe);
-
-      { different assignment types }
-
-      tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash);
-
-      pcaserecord = ^tcaserecord;
-      tcaserecord = record
-
-          { range }
-          _low,_high : TConstExprInt;
-
-          { only used by gentreejmp }
-          _at : pasmlabel;
-
-          { label of instruction }
-          statement : pasmlabel;
-
-          { is this the first of an case entry, needed to release statement
-            label (PFV) }
-          firstlabel : boolean;
-
-          { left and right tree node }
-          less,greater : pcaserecord;
-       end;
-
-       ptree = ^ttree;
-       ttree = record
-          error : boolean;
-          disposetyp : tdisposetyp;
-          { is true, if the right and left operand are swaped }
-          swaped : boolean;
-          { do we need to parse childs to set var state }
-          varstateset : boolean;
-          { the location of the result of this node }
-          location : tlocation;
-
-          { the number of registers needed to evalute the node }
-          registers32,registersfpu : longint;  { must be longint !!!! }
-{$ifdef SUPPORT_MMX}
-          registersmmx : longint;
-{$endif SUPPORT_MMX}
-          left,right : ptree;
-          resulttype : pdef;
-          fileinfo : tfileposinfo;
-          localswitches : tlocalswitches;
-          isproperty : boolean;
-{$ifdef extdebug}
-          firstpasscount : longint;
-{$endif extdebug}
-{$ifdef TEMPREGDEBUG}
-          usableregs : longint;
-{$endif TEMPREGDEBUG}
-{$ifdef EXTTEMPREGDEBUG}
-          reallyusedregs : longint;
-{$endif EXTTEMPREGDEBUG}
-{$ifdef TEMPS_NOT_PUSH}
-          temp_offset : longint;
-{$endif TEMPS_NOT_PUSH}
-          case treetype : ttreetyp of
-             addn : (use_strconcat : boolean;string_typ : tstringtype);
-             callparan : (is_colon_para : boolean;exact_match_found,
-                          convlevel1found,convlevel2found:boolean;hightree:ptree);
-             assignn : (assigntyp : tassigntyp;concat_string : boolean);
-             loadn : (symtableentry : psym;symtable : psymtable;
-                      is_absolute,is_first : boolean);
-             calln : (symtableprocentry : pprocsym;
-                      symtableproc : psymtable;procdefinition : pabstractprocdef;
-                      methodpointer : ptree;
-                      no_check,unit_specific,
-                      return_value_used,static_call : boolean);
-             addrn : (procvarload:boolean);
-             ordconstn : (value : TConstExprInt);
-             realconstn : (value_real : bestreal;lab_real : pasmlabel);
-             fixconstn : (value_fix: longint);
-             funcretn : (funcretprocinfo : pointer;
-                       {$IFDEF NEWST}
-                       retsym:Psym;
-                       {$ELSE}
-                       rettype : ttype;
-                       {$ENDIF}
-                       is_first_funcret : boolean);
-             subscriptn : (vs : pvarsym);
-             raisen : (frametree : ptree);
-             vecn : (memindex,memseg:boolean;callunique : boolean);
-             stringconstn : (value_str : pchar;length : longint; lab_str : pasmlabel;stringtype : tstringtype);
-             typeconvn : (convtyp : tconverttype;explizit : boolean);
-             typen : (typenodetype : pdef;typenodesym:ptypesym);
-             inlinen : (inlinenumber : byte;inlineconst:boolean);
-             procinlinen : (inlinetree:ptree;inlineprocsym:pprocsym;retoffset,para_offset,para_size : longint);
-             setconstn : (value_set : pconstset;lab_set:pasmlabel);
-             loopn : (t1,t2 : ptree;backward : boolean);
-             asmn : (p_asm : paasmoutput;object_preserved : boolean);
-             casen : (nodes : pcaserecord;elseblock : ptree);
-             labeln,goton : (labelnr : pasmlabel;exceptionblock : ptree;labsym : plabelsym);
-        {$IFDEF NEWST}
-             withn : (withsymtables:Pcollection;
-                      withreference:preference;
-                      islocal:boolean);
-        {$ELSE}
-             withn : (withsymtable : pwithsymtable;
-                      tablecount : longint;
-                      withreference:preference;
-                      islocal:boolean);
-        {$ENDIF NEWST}
-             onn : (exceptsymtable : psymtable;excepttype : pobjectdef);
-             arrayconstructn : (cargs,cargswap,forcevaria,novariaallowed: boolean;constructdef:pdef);
-           end;
-
-    function gennode(t : ttreetyp;l,r : ptree) : ptree;
-    function genlabelnode(t : ttreetyp;nr : pasmlabel) : ptree;
-    function genloadnode(v : pvarsym;st : psymtable) : ptree;
-    function genloadcallnode(v: pprocsym;st: psymtable): ptree;
-    function genloadmethodcallnode(v: pprocsym;st: psymtable; mp:ptree): ptree;
-    function gensinglenode(t : ttreetyp;l : ptree) : ptree;
-    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
-    function genordinalconstnode(v : TConstExprInt;def : pdef) : ptree;
-    { same as genordinalconstnode, but the resulttype }
-    { is determines automatically                     }
-    function genintconstnode(v : TConstExprInt) : ptree;
-    function genpointerconstnode(v : tpointerord;def : pdef) : ptree;
-    function genfixconstnode(v : longint;def : pdef) : ptree;
-    function gentypeconvnode(node : ptree;t : pdef) : ptree;
-    function gentypenode(t : pdef;sym:ptypesym) : ptree;
-    function gencallparanode(expr,next : ptree) : ptree;
-    function genrealconstnode(v : bestreal;def : pdef) : ptree;
-    function gencallnode(v : pprocsym;st : psymtable) : ptree;
-    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
-
-    { allow pchar or string for defining a pchar node }
-    function genstringconstnode(const s : string;st:tstringtype) : ptree;
-    { length is required for ansistrings }
-    function genpcharconstnode(s : pchar;length : longint) : ptree;
-    { helper routine for conststring node }
-    function getpcharcopy(p : ptree) : pchar;
-
-    function genzeronode(t : ttreetyp) : ptree;
-    function geninlinenode(number : byte;is_const:boolean;l : ptree) : ptree;
-    function genprocinlinenode(callp,code : ptree) : ptree;
-    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
-    function genenumnode(v : penumsym) : ptree;
-    function genselfnode(_class : pdef) : ptree;
-    function gensetconstnode(s : pconstset;settype : psetdef) : ptree;
-    function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree;
-    function genasmnode(p_asm : paasmoutput) : ptree;
-    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
-{$IFDEF NEWST}
-    function genwithnode(symtables:Pcollection;l,r : ptree) : ptree;
-{$ELSE}
-    function genwithnode(symtable:pwithsymtable;l,r : ptree;count : longint) : ptree;
-{$ENDIF NEWST}
-    function genconstsymtree(p:pconstsym):ptree;
-
-    function getcopy(p : ptree) : ptree;
-
-    function equal_trees(t1,t2 : ptree) : boolean;
-{$ifdef newoptimizations2}
-    { checks if t1 is loaded more than once in t2 and its sub-trees }
-    function multiple_uses(t1,t2: ptree): boolean;
-{$endif newoptimizations2}
-
-    procedure swaptree(p:Ptree);
-    procedure disposetree(p : ptree);
-    procedure putnode(p : ptree);
-    function getnode : ptree;
-    procedure clear_location(var loc : tlocation);
-    procedure set_location(var destloc,sourceloc : tlocation);
-    procedure swap_location(var destloc,sourceloc : tlocation);
-    procedure set_file_line(from,_to : ptree);
-    procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
-{$ifdef extdebug}
-    procedure compare_trees(oldp,p : ptree);
-    const
-       maxfirstpasscount : longint = 0;
-{$endif extdebug}
-
-    {
-    type
-    tvarstaterequire = (vsr_can_be_undefined,vsr_must_be_valid,
-      vsr_is_used_after,vsr_must_be_valid_and_is_used_after); }
-
-    { returns the ordinal value of the node, if it hasn't a ord. }
-    { value an error is generated                                }
-    function get_ordinal_value(p : ptree) : longint;
-
-    function is_constnode(p : ptree) : boolean;
-    { true, if p is a pointer to a const int value }
-    function is_constintnode(p : ptree) : boolean;
-    function is_constboolnode(p : ptree) : boolean;
-    function is_constrealnode(p : ptree) : boolean;
-    function is_constcharnode(p : ptree) : boolean;
-    function is_constresourcestringnode(p : ptree) : boolean;
-
-    function str_length(p : ptree) : longint;
-    function is_emptyset(p : ptree):boolean;
-
-    { counts the labels }
-    function case_count_labels(root : pcaserecord) : longint;
-    { searches the highest label }
-    function case_get_max(root : pcaserecord) : longint;
-    { searches the lowest label }
-    function case_get_min(root : pcaserecord) : longint;
-
-    type
-      pptree = ^ptree;
-
-{$ifdef TEMPREGDEBUG}
-    const
-      curptree : pptree = nil;
-{$endif TEMPREGDEBUG}
-
-{$I innr.inc}
-
-{$ifdef newcg}
-{$I nodeh.inc}
-{$endif newcg}
-  implementation
-
-    uses
-       systems,
-       cutils,globals,verbose,fmodule,types,
-{$ifdef newcg}
-       cgbase
-{$else newcg}
-       hcodegen
-{$endif newcg}
-{$IFDEF NEWST}
-       ,symtablt
-{$ENDIF}
-       ;
-
-    function getnode : ptree;
-
-      var
-         hp : ptree;
-
-      begin
-         new(hp);
-         { makes error tracking easier }
-         fillchar(hp^,sizeof(ttree),0);
-         { reset }
-         hp^.location.loc:=LOC_INVALID;
-         { save local info }
-         hp^.fileinfo:=aktfilepos;
-         hp^.localswitches:=aktlocalswitches;
-         getnode:=hp;
-      end;
-
-
-    procedure putnode(p : ptree);
-      begin
-         { clean up the contents of a node }
-         case p^.treetype of
-          asmn : if assigned(p^.p_asm) then
-                  dispose(p^.p_asm,done);
-  stringconstn : begin
-                   ansistringdispose(p^.value_str,p^.length);
-                 end;
-     setconstn : begin
-                   if assigned(p^.value_set) then
-                     dispose(p^.value_set);
-                 end;
-         end;
-{$ifdef extdebug}
-         if p^.firstpasscount>maxfirstpasscount then
-            maxfirstpasscount:=p^.firstpasscount;
-{$endif extdebug}
-         dispose(p);
-      end;
-
-    function getcopy(p : ptree) : ptree;
-
-      var
-         hp : ptree;
-
-      begin
-         if not assigned(p) then
-          begin
-            getcopy:=nil;
-            exit;
-          end;
-         hp:=getnode;
-         hp^:=p^;
-         case p^.disposetyp of
-            dt_leftright :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 if assigned(p^.right) then
-                   hp^.right:=getcopy(p^.right);
-              end;
-            dt_leftrighthigh :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 if assigned(p^.right) then
-                   hp^.right:=getcopy(p^.right);
-                 if assigned(p^.hightree) then
-                   hp^.hightree:=getcopy(p^.hightree);
-              end;
-            dt_leftrightframe :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 if assigned(p^.right) then
-                   hp^.right:=getcopy(p^.right);
-                 if assigned(p^.frametree) then
-                   hp^.frametree:=getcopy(p^.frametree);
-              end;
-            dt_leftrightmethod :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 if assigned(p^.right) then
-                   hp^.right:=getcopy(p^.right);
-                 if assigned(p^.methodpointer) then
-                   hp^.methodpointer:=getcopy(p^.methodpointer);
-              end;
-            dt_nothing : ;
-            dt_left    :
-              if assigned(p^.left) then
-                hp^.left:=getcopy(p^.left);
-            dt_mbleft :
-              if assigned(p^.left) then
-                hp^.left:=getcopy(p^.left);
-            dt_mbleft_and_method :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 hp^.methodpointer:=getcopy(p^.methodpointer);
-              end;
-            dt_loop :
-              begin
-                 if assigned(p^.left) then
-                   hp^.left:=getcopy(p^.left);
-                 if assigned(p^.right) then
-                   hp^.right:=getcopy(p^.right);
-                 if assigned(p^.t1) then
-                   hp^.t1:=getcopy(p^.t1);
-                 if assigned(p^.t2) then
-                   hp^.t2:=getcopy(p^.t2);
-              end;
-            dt_typeconv : hp^.left:=getcopy(p^.left);
-            dt_inlinen :
-              if assigned(p^.left) then
-                hp^.left:=getcopy(p^.left);
-            else internalerror(11);
-         end;
-       { now check treetype }
-         case p^.treetype of
-  stringconstn : begin
-                   hp^.value_str:=getpcharcopy(p);
-                   hp^.length:=p^.length;
-                 end;
-     setconstn : begin
-                   new(hp^.value_set);
-                   hp^.value_set:=p^.value_set;
-                 end;
-         end;
-         getcopy:=hp;
-      end;
-
-    procedure deletecaselabels(p : pcaserecord);
-
-      begin
-         if assigned(p^.greater) then
-           deletecaselabels(p^.greater);
-         if assigned(p^.less) then
-           deletecaselabels(p^.less);
-         dispose(p);
-      end;
-
-    procedure swaptree(p:Ptree);
-
-    var swapp:Ptree;
-
-    begin
-        swapp:=p^.right;
-        p^.right:=p^.left;
-        p^.left:=swapp;
-        p^.swaped:=not(p^.swaped);
-    end;
-
-
-    procedure disposetree(p : ptree);
-
-      var
-         symt : psymtable;
-         i : longint;
-
-      begin
-         if not(assigned(p)) then
-           exit;
-         if not(p^.treetype in [addn..loadvmtn]) then
-           internalerror(26219);
-         case p^.disposetyp of
-            dt_leftright :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-              end;
-            dt_leftrighthigh :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.hightree) then
-                   disposetree(p^.hightree);
-              end;
-            dt_leftrightframe :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.frametree) then
-                   disposetree(p^.frametree);
-              end;
-            dt_leftrightmethod :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.methodpointer) then
-                   disposetree(p^.methodpointer);
-              end;
-            dt_case :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.nodes) then
-                   deletecaselabels(p^.nodes);
-                 if assigned(p^.elseblock) then
-                   disposetree(p^.elseblock);
-              end;
-            dt_nothing : ;
-            dt_left    :
-              if assigned(p^.left) then
-                disposetree(p^.left);
-            dt_mbleft :
-              if assigned(p^.left) then
-                disposetree(p^.left);
-            dt_mbleft_and_method :
-              begin
-                 if assigned(p^.left) then disposetree(p^.left);
-                 disposetree(p^.methodpointer);
-              end;
-            dt_typeconv : disposetree(p^.left);
-            dt_inlinen :
-              if assigned(p^.left) then
-                disposetree(p^.left);
-            dt_loop :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.t1) then
-                   disposetree(p^.t1);
-                 if assigned(p^.t2) then
-                   disposetree(p^.t2);
-              end;
-            dt_onn:
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-                 if assigned(p^.exceptsymtable) then
-                   dispose(p^.exceptsymtable,done);
-              end;
-            dt_with :
-              begin
-                 if assigned(p^.left) then
-                   disposetree(p^.left);
-                 if assigned(p^.right) then
-                   disposetree(p^.right);
-              {$IFDEF NEWST}
-                 dispose(p^.withsymtables,done);
-              {$ELSE}
-                 symt:=p^.withsymtable;
-                 for i:=1 to p^.tablecount do
-                   begin
-                      if assigned(symt) then
-                        begin
-                           p^.withsymtable:=pwithsymtable(symt^.next);
-                           dispose(symt,done);
-                        end;
-                      symt:=p^.withsymtable;
-                   end;
-              {$ENDIF NEWST}
-              end;
-            else internalerror(12);
-         end;
-         putnode(p);
-      end;
-
-    procedure set_file_line(from,_to : ptree);
-
-      begin
-         if assigned(from) then
-           _to^.fileinfo:=from^.fileinfo;
-      end;
-
-   procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
-     begin
-        p^.fileinfo:=filepos;
-     end;
-
-{$IFDEF NEWST}
-   function genwithnode(symtables:Pcollection;l,r : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_with;
-         p^.treetype:=withn;
-         p^.left:=l;
-         p^.right:=r;
-         p^.registers32:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         p^.withsymtables:=symtables;
-         p^.withreference:=nil;
-         p^.islocal:=false;
-         set_file_line(l,p);
-         genwithnode:=p;
-      end;
-{$ELSE}
-   function genwithnode(symtable : pwithsymtable;l,r : ptree;count : longint) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_with;
-         p^.treetype:=withn;
-         p^.left:=l;
-         p^.right:=r;
-         p^.registers32:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         p^.withsymtable:=symtable;
-         p^.tablecount:=count;
-         p^.withreference:=nil;
-         p^.islocal:=false;
-         set_file_line(l,p);
-         genwithnode:=p;
-      end;
-{$ENDIF NEWST}
-
-    function genfixconstnode(v : longint;def : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=fixconstn;
-         p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=def;
-         p^.value:=v;
-         genfixconstnode:=p;
-      end;
-
-    function gencallparanode(expr,next : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_leftrighthigh;
-         p^.treetype:=callparan;
-         p^.left:=expr;
-         p^.right:=next;
-         p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.registersfpu:=0;
-         p^.resulttype:=nil;
-         p^.exact_match_found:=false;
-         p^.convlevel1found:=false;
-         p^.convlevel2found:=false;
-         p^.is_colon_para:=false;
-         p^.hightree:=nil;
-         set_file_line(expr,p);
-         gencallparanode:=p;
-      end;
-
-    function gennode(t : ttreetyp;l,r : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_leftright;
-         p^.treetype:=t;
-         p^.left:=l;
-         p^.right:=r;
-         p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         gennode:=p;
-      end;
-
-    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_case;
-         p^.treetype:=casen;
-         p^.left:=l;
-         p^.right:=r;
-         p^.nodes:=nodes;
-         p^.registers32:=0;
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         set_file_line(l,p);
-         gencasenode:=p;
-      end;
-
-    function genloopnode(t : ttreetyp;l,r,n1 : ptree;back : boolean) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_loop;
-         p^.treetype:=t;
-         p^.left:=l;
-         p^.right:=r;
-         p^.t1:=n1;
-         p^.t2:=nil;
-         p^.registers32:=0;
-         p^.backward:=back;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         set_file_line(l,p);
-         genloopnode:=p;
-      end;
-
-    function genordinalconstnode(v : tconstexprint;def : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=ordconstn;
-         p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=def;
-         p^.value:=v;
-      {$IFDEF NEWST}
-         if typeof(p^.resulttype^)=typeof(Torddef) then
-          testrange(p^.resulttype,p^.value);
-      {$ELSE NEWST}
-         if p^.resulttype^.deftype=orddef then
-          testrange(p^.resulttype,p^.value);
-      {$ENDIF}
-         genordinalconstnode:=p;
-      end;
-
-    function genintconstnode(v : TConstExprInt) : ptree;
-
-      var
-         i : TConstExprInt;
-
-      begin
-         { we need to bootstrap this code, so it's a little bit messy }
-         i:=2147483647;
-         if (v<=i) and (v>=-i-1) then
-           genintconstnode:=genordinalconstnode(v,s32bitdef)
-         else
-           genintconstnode:=genordinalconstnode(v,cs64bitdef);
-      end;
-
-    function genpointerconstnode(v : tpointerord;def : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=pointerconstn;
-         p^.registers32:=0;
-         { p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=def;
-         p^.value:=v;
-         genpointerconstnode:=p;
-      end;
-
-    function genenumnode(v : penumsym) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=ordconstn;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=v^.definition;
-         p^.value:=v^.value;
-         testrange(p^.resulttype,p^.value);
-         genenumnode:=p;
-      end;
-
-
-    function genrealconstnode(v : bestreal;def : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=realconstn;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=def;
-         p^.value_real:=v;
-         p^.lab_real:=nil;
-         genrealconstnode:=p;
-      end;
-
-
-    function genstringconstnode(const s : string;st:tstringtype) : ptree;
-
-      var
-         p : ptree;
-         l : longint;
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=stringconstn;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         l:=length(s);
-         p^.length:=l;
-         { stringdup write even past a #0 }
-         getmem(p^.value_str,l+1);
-         move(s[1],p^.value_str^,l);
-         p^.value_str[l]:=#0;
-         p^.lab_str:=nil;
-         if st=st_default then
-          begin
-            if cs_ansistrings in aktlocalswitches then
-             p^.stringtype:=st_ansistring
-            else
-             p^.stringtype:=st_shortstring;
-          end
-         else
-          p^.stringtype:=st;
-         case p^.stringtype of
-           st_shortstring :
-             p^.resulttype:=cshortstringdef;
-           st_ansistring :
-            p^.resulttype:=cansistringdef;
-           else
-             internalerror(44990099);
-         end;
-         genstringconstnode:=p;
-      end;
-
-    function getpcharcopy(p : ptree) : pchar;
-      var
-         pc : pchar;
-      begin
-         pc:=nil;
-         getmem(pc,p^.length+1);
-         if pc=nil then
-           Message(general_f_no_memory_left);
-         move(p^.value_str^,pc^,p^.length+1);
-         getpcharcopy:=pc;
-      end;
-
-
-    function genpcharconstnode(s : pchar;length : longint) : ptree;
-      var
-         p : ptree;
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=stringconstn;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.length:=length;
-         if (cs_ansistrings in aktlocalswitches) or
-            (length>255) then
-          begin
-            p^.stringtype:=st_ansistring;
-            p^.resulttype:=cansistringdef;
-          end
-         else
-          begin
-            p^.stringtype:=st_shortstring;
-            p^.resulttype:=cshortstringdef;
-          end;
-         p^.value_str:=s;
-         p^.lab_str:=nil;
-         genpcharconstnode:=p;
-      end;
-
-
-    function gensinglenode(t : ttreetyp;l : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_left;
-         p^.treetype:=t;
-         p^.left:=l;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         gensinglenode:=p;
-      end;
-
-    function genasmnode(p_asm : paasmoutput) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=asmn;
-         p^.registers32:=4;
-         p^.p_asm:=p_asm;
-         p^.object_preserved:=false;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=8;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=8;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         genasmnode:=p;
-      end;
-
-    function genloadnode(v : pvarsym;st : psymtable) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=loadn;
-      {$IFDEF NEWST}
-         p^.resulttype:=v^.definition;
-      {$ELSE}
-         p^.resulttype:=v^.vartype.def;
-      {$ENDIF NEWST}
-         p^.symtableentry:=v;
-         p^.symtable:=st;
-         p^.is_first := False;
-         { method pointer load nodes can use the left subtree }
-         p^.disposetyp:=dt_left;
-         p^.left:=nil;
-         genloadnode:=p;
-      end;
-
-    function genloadcallnode(v: pprocsym;st: psymtable): ptree;
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=loadn;
-         p^.left:=nil;
-      {$IFDEF NEWST}
-         p^.resulttype:=nil; {We don't know which overloaded procedure is
-                              wanted...}
-      {$ELSE}
-         p^.resulttype:=v^.definition;
-      {$ENDIF}
-         p^.symtableentry:=v;
-         p^.symtable:=st;
-         p^.is_first := False;
-         p^.disposetyp:=dt_nothing;
-         genloadcallnode:=p;
-      end;
-
-    function genloadmethodcallnode(v: pprocsym;st: psymtable; mp:ptree): ptree;
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=loadn;
-         p^.left:=nil;
-      {$IFDEF NEWST}
-         p^.resulttype:=nil; {We don't know which overloaded procedure is
-                              wanted...}
-      {$ELSE}
-         p^.resulttype:=v^.definition;
-      {$ENDIF}
-         p^.symtableentry:=v;
-         p^.symtable:=st;
-         p^.is_first := False;
-         p^.disposetyp:=dt_left;
-         p^.left:=mp;
-         genloadmethodcallnode:=p;
-      end;
-
-
-    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=loadn;
-         p^.left:=nil;
-      {$IFDEF NEWST}
-         p^.resulttype:=sym^.definition;
-      {$ELSE}
-         p^.resulttype:=sym^.typedconsttype.def;
-      {$ENDIF NEWST}
-         p^.symtableentry:=sym;
-         p^.symtable:=st;
-         p^.disposetyp:=dt_nothing;
-         gentypedconstloadnode:=p;
-      end;
-
-    function gentypeconvnode(node : ptree;t : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_typeconv;
-         p^.treetype:=typeconvn;
-         p^.left:=node;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.convtyp:=tc_equal;
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=t;
-         p^.explizit:=false;
-         set_file_line(node,p);
-         gentypeconvnode:=p;
-      end;
-
-    function gentypenode(t : pdef;sym:ptypesym) : ptree;
-      var
-         p : ptree;
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=typen;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=generrordef;
-         p^.typenodetype:=t;
-         p^.typenodesym:=sym;
-         gentypenode:=p;
-      end;
-
-    function gencallnode(v : pprocsym;st : psymtable) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=calln;
-         p^.symtableprocentry:=v;
-         p^.symtableproc:=st;
-         p^.unit_specific:=false;
-         p^.no_check:=false;
-         p^.return_value_used:=true;
-         p^.disposetyp := dt_leftrightmethod;
-         p^.methodpointer:=nil;
-         p^.left:=nil;
-         p^.right:=nil;
-         p^.procdefinition:=nil;
-         gencallnode:=p;
-      end;
-
-    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.treetype:=calln;
-         p^.return_value_used:=true;
-         p^.symtableprocentry:=v;
-         p^.symtableproc:=st;
-         p^.disposetyp:=dt_leftrightmethod;
-         p^.left:=nil;
-         p^.right:=nil;
-         p^.methodpointer:=mp;
-         p^.procdefinition:=nil;
-         genmethodcallnode:=p;
-      end;
-
-    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_left;
-         p^.treetype:=subscriptn;
-         p^.left:=l;
-         p^.registers32:=0;
-         p^.vs:=varsym;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         gensubscriptnode:=p;
-      end;
-
-   function genzeronode(t : ttreetyp) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=t;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         genzeronode:=p;
-      end;
-
-   function genlabelnode(t : ttreetyp;nr : pasmlabel) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=t;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         { for security }
-         { nr^.is_used:=true;}
-         p^.labelnr:=nr;
-         p^.exceptionblock:=nil;
-         genlabelnode:=p;
-      end;
-
-    function genselfnode(_class : pdef) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=selfn;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=_class;
-         genselfnode:=p;
-      end;
-
-   function geninlinenode(number : byte;is_const:boolean;l : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_inlinen;
-         p^.treetype:=inlinen;
-         p^.left:=l;
-         p^.inlinenumber:=number;
-         p^.inlineconst:=is_const;
-         p^.registers32:=0;
-{        p^.registers16:=0;
-         p^.registers8:=0; }
-         p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=nil;
-         geninlinenode:=p;
-      end;
-
-
-      { uses the callnode to create the new procinline node }
-    function genprocinlinenode(callp,code : ptree) : ptree;
-
-      var
-         p : ptree;
-
-      begin
-         p:=getnode;
-         p^.disposetyp:=dt_nothing;
-         p^.treetype:=procinlinen;
-         p^.inlineprocsym:=callp^.symtableprocentry;
-         p^.retoffset:=-4; { less dangerous as zero (PM) }
-         p^.para_offset:=0;
-      {$IFDEF NEWST}
-         {Fixme!!}
-         internalerror($00022801);
-      {$ELSE}
-         p^.para_size:=p^.inlineprocsym^.definition^.para_size(target_os.stackalignment);
-         if ret_in_param(p^.inlineprocsym^.definition^.rettype.def) then
-           p^.para_size:=p^.para_size+target_os.size_of_pointer;
-      {$ENDIF NEWST}
-         { copy args }
-         p^.inlinetree:=code;
-         p^.registers32:=code^.registers32;
-         p^.registersfpu:=code^.registersfpu;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-      {$IFDEF NEWST}
-         {Fixme!!}
-      {$ELSE}
-         p^.resulttype:=p^.inlineprocsym^.definition^.rettype.def;
-      {$ENDIF NEWST}
-         genprocinlinenode:=p;
-      end;
-
-   function gensetconstnode(s : pconstset;settype : psetdef) : ptree;
-
-     var
-        p : ptree;
-
-     begin
-        p:=getnode;
-        p^.disposetyp:=dt_nothing;
-        p^.treetype:=setconstn;
-        p^.registers32:=0;
-        p^.registersfpu:=0;
-{$ifdef SUPPORT_MMX}
-         p^.registersmmx:=0;
-{$endif SUPPORT_MMX}
-         p^.resulttype:=settype;
-         p^.left:=nil;
-         new(p^.value_set);
-         p^.value_set^:=s^;
-         gensetconstnode:=p;
-      end;
-
-
-    function genconstsymtree(p:pconstsym):ptree;
-      var
-        p1  : ptree;
-        len : longint;
-        pc  : pchar;
-      begin
-        p1:=nil;
-        case p^.consttyp of
-          constint :
-            p1:=genordinalconstnode(p^.value,s32bitdef);
-          conststring :
-            begin
-              len:=p^.len;
-              if not(cs_ansistrings in aktlocalswitches) and (len>255) then
-               len:=255;
-              getmem(pc,len+1);
-              move(pchar(tpointerord(p^.value))^,pc^,len);
-              pc[len]:=#0;
-              p1:=genpcharconstnode(pc,len);
-            end;
-          constchar :
-            p1:=genordinalconstnode(p^.value,cchardef);
-          constreal :
-            p1:=genrealconstnode(pbestreal(tpointerord(p^.value))^,bestrealdef^);
-          constbool :
-            p1:=genordinalconstnode(p^.value,booldef);
-          constset :
-            p1:=gensetconstnode(pconstset(tpointerord(p^.value)),psetdef(p^.consttype.def));
-          constord :
-            p1:=genordinalconstnode(p^.value,p^.consttype.def);
-          constpointer :
-            p1:=genpointerconstnode(p^.value,p^.consttype.def);
-          constnil :
-            p1:=genzeronode(niln);
-          constresourcestring:
-            begin
-              p1:=genloadnode(pvarsym(p),pvarsym(p)^.owner);
-              p1^.resulttype:=cansistringdef;
-            end;
-        end;
-        genconstsymtree:=p1;
-      end;
-
-
-{$ifdef extdebug}
-    procedure compare_trees(oldp,p : ptree);
-
-      var
-         error_found : boolean;
-
-      begin
-          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 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 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 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 oldp^.registers32<>p^.registers32 then
-           begin
-              comment(v_warning,'registers32 field different');
-              comment(v_warning,' old '+tostr(oldp^.registers32)+'<> new '+tostr(p^.registers32));
-              error_found:=true;
-           end;
-          if oldp^.registersfpu<>p^.registersfpu then
-           begin
-              comment(v_warning,'registersfpu field different');
-              error_found:=true;
-           end;
-{$ifdef SUPPORT_MMX}
-          if oldp^.registersmmx<>p^.registersmmx then
-           begin
-              comment(v_warning,'registersmmx field different');
-              error_found:=true;
-           end;
-{$endif SUPPORT_MMX}
-          if oldp^.left<>p^.left then
-           begin
-              comment(v_warning,'left field different');
-              error_found:=true;
-           end;
-          if oldp^.right<>p^.right then
-           begin
-              comment(v_warning,'right field different');
-              error_found:=true;
-           end;
-          if oldp^.fileinfo.line<>p^.fileinfo.line then
-            begin
-               comment(v_warning,'fileinfo.line field different');
-               error_found:=true;
-            end;
-          if oldp^.fileinfo.column<>p^.fileinfo.column then
-            begin
-               comment(v_warning,'fileinfo.column field different');
-               error_found:=true;
-            end;
-          if oldp^.fileinfo.fileindex<>p^.fileinfo.fileindex then
-            begin
-               comment(v_warning,'fileinfo.fileindex field different');
-               error_found:=true;
-            end;
-          if oldp^.localswitches<>p^.localswitches then
-            begin
-               comment(v_warning,'localswitches field different');
-               error_found:=true;
-            end;
-{$ifdef extdebug}
-          if oldp^.firstpasscount<>p^.firstpasscount then
-            begin
-               comment(v_warning,'firstpasscount field different');
-               error_found:=true;
-            end;
-{$endif extdebug}
-          if oldp^.treetype=p^.treetype then
-          case oldp^.treetype of
-             addn :
-             begin
-                if oldp^.use_strconcat<>p^.use_strconcat then
-                  begin
-                     comment(v_warning,'use_strconcat field different');
-                     error_found:=true;
-                  end;
-                if oldp^.string_typ<>p^.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 oldp^.is_colon_para<>p^.is_colon_para then
-                  begin
-                     comment(v_warning,'use_strconcat field different');
-                     error_found:=true;
-                  end;
-                if oldp^.exact_match_found<>p^.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 oldp^.assigntyp<>p^.assigntyp then
-                  begin
-                     comment(v_warning,'assigntyp field different');
-                     error_found:=true;
-                  end;
-                if oldp^.concat_string<>p^.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 oldp^.symtableentry<>p^.symtableentry then
-                  begin
-                     comment(v_warning,'symtableentry field different');
-                     error_found:=true;
-                  end;
-                if oldp^.symtable<>p^.symtable then
-                  begin
-                     comment(v_warning,'symtable field different');
-                     error_found:=true;
-                  end;
-                if oldp^.is_absolute<>p^.is_absolute then
-                  begin
-                     comment(v_warning,'is_absolute field different');
-                     error_found:=true;
-                  end;
-                if oldp^.is_first<>p^.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 oldp^.symtableprocentry<>p^.symtableprocentry then
-                  begin
-                     comment(v_warning,'symtableprocentry field different');
-                     error_found:=true;
-                  end;
-                if oldp^.symtableproc<>p^.symtableproc then
-                  begin
-                     comment(v_warning,'symtableproc field different');
-                     error_found:=true;
-                  end;
-                if oldp^.procdefinition<>p^.procdefinition then
-                  begin
-                     comment(v_warning,'procdefinition field different');
-                     error_found:=true;
-                  end;
-                if oldp^.methodpointer<>p^.methodpointer then
-                  begin
-                     comment(v_warning,'methodpointer field different');
-                     error_found:=true;
-                  end;
-                if oldp^.no_check<>p^.no_check then
-                  begin
-                     comment(v_warning,'no_check field different');
-                     error_found:=true;
-                  end;
-                if oldp^.unit_specific<>p^.unit_specific then
-                  begin
-                     error_found:=true;
-                     comment(v_warning,'unit_specific field different');
-                  end;
-             end;
-             ordconstn :
-               begin
-                  if oldp^.value<>p^.value then
-                  begin
-                     comment(v_warning,'value field different');
-                     error_found:=true;
-                  end;
-               end;
-             realconstn :
-               begin
-                  if oldp^.value_real<>p^.value_real then
-                  begin
-                     comment(v_warning,'valued field different');
-                     error_found:=true;
-                  end;
-                  if oldp^.lab_real<>p^.lab_real then
-                  begin
-                     comment(v_warning,'labnumber field different');
-                     error_found:=true;
-                  end;
-                  { if oldp^.realtyp<>p^.realtyp then
-                  begin
-                     comment(v_warning,'realtyp field different');
-                     error_found:=true;
-                  end; }
-               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
-         if t1^.treetype=t2^.treetype then
-           begin
-              case t1^.treetype of
-                 addn,
-                 muln,
-                 equaln,
-                 orn,
-                 xorn,
-                 andn,
-                 unequaln:
-                   begin
-                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
-                                    equal_trees(t1^.right,t2^.right)) or
-                                   (equal_trees(t1^.right,t2^.left) and
-                                    equal_trees(t1^.left,t2^.right));
-                   end;
-                 subn,
-                 divn,
-                 modn,
-                 assignn,
-                 ltn,
-                 lten,
-                 gtn,
-                 gten,
-                 inn,
-                 shrn,
-                 shln,
-                 slashn,
-                 rangen:
-                   begin
-                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
-                                    equal_trees(t1^.right,t2^.right));
-                   end;
-                 unaryminusn,
-                 notn,
-                 derefn,
-                 addrn:
-                   begin
-                      equal_trees:=(equal_trees(t1^.left,t2^.left));
-                   end;
-                loadn:
-                   begin
-                      equal_trees:=(t1^.symtableentry=t2^.symtableentry)
-                        { not necessary
-                                     and (t1^.symtable=t2^.symtable)};
-                   end;
-                {
-
-                   subscriptn,
-                   ordconstn,typeconvn,calln,callparan,
-                   realconstn,asmn,vecn,
-                   stringconstn,funcretn,selfn,
-                   inlinen,niln,errorn,
-                   typen,hnewn,hdisposen,newn,
-                   disposen,setelen,setconstrn
-                }
-                else equal_trees:=false;
-             end;
-          end
-        else
-          equal_trees:=false;
-     end;
-
-{$ifdef newoptimizations2}
-    function multiple_uses(t1,t2: ptree): boolean;
-    var nr: longint;
-
-      procedure check_tree(t: ptree);
-      begin
-        inc(nr,ord(equal_trees(t1,t)));
-        if (nr < 2) and assigned(t^.left) then
-          check_tree(t^.left);
-        if (nr < 2) and assigned(t^.right) then
-          check_tree(t^.right);
-      end;
-
-    begin
-       nr := 0;
-       check_tree(t2);
-       multiple_uses := nr > 1;
-    end;
-{$endif newoptimizations2}
-
-
-    procedure clear_location(var loc : tlocation);
-
-      begin
-        loc.loc:=LOC_INVALID;
-      end;
-
-    {This is needed if you want to be able to delete the string with the nodes !!}
-    procedure set_location(var destloc,sourceloc : tlocation);
-
-      begin
-        destloc:= sourceloc;
-      end;
-
-    procedure swap_location(var destloc,sourceloc : tlocation);
-
-      var
-         swapl : tlocation;
-
-      begin
-         swapl := destloc;
-         destloc := sourceloc;
-         sourceloc := swapl;
-      end;
-
-
-    function get_ordinal_value(p : ptree) : longint;
-      begin
-         if p^.treetype=ordconstn then
-           get_ordinal_value:=p^.value
-         else
-           begin
-             Message(type_e_ordinal_expr_expected);
-             get_ordinal_value:=0;
-           end;
-      end;
-
-
-    function is_constnode(p : ptree) : boolean;
-      begin
-        is_constnode:=(p^.treetype in [ordconstn,realconstn,stringconstn,fixconstn,setconstn]);
-      end;
-
-
-    function is_constintnode(p : ptree) : boolean;
-      begin
-         is_constintnode:=(p^.treetype=ordconstn) and is_integer(p^.resulttype);
-      end;
-
-
-    function is_constcharnode(p : ptree) : boolean;
-
-      begin
-         is_constcharnode:=(p^.treetype=ordconstn) and is_char(p^.resulttype);
-      end;
-
-    function is_constrealnode(p : ptree) : boolean;
-
-      begin
-         is_constrealnode:=(p^.treetype=realconstn);
-      end;
-
-    function is_constboolnode(p : ptree) : boolean;
-
-      begin
-         is_constboolnode:=(p^.treetype=ordconstn) and is_boolean(p^.resulttype);
-      end;
-
-
-    function is_constresourcestringnode(p : ptree) : boolean;
-      begin
-        is_constresourcestringnode:=(p^.treetype=loadn) and
-                                    (p^.symtableentry^.typ=constsym) and
-                                    (pconstsym(p^.symtableentry)^.consttyp=constresourcestring);
-      end;
-
-
-    function str_length(p : ptree) : longint;
-
-      begin
-         str_length:=p^.length;
-      end;
-
-
-    function is_emptyset(p : ptree):boolean;
-    {
-      return true if set s is empty
-    }
-      var
-        i : longint;
-      begin
-        i:=0;
-        if p^.treetype=setconstn then
-         begin
-           while (i<32) and (p^.value_set^[i]=0) do
-            inc(i);
-         end;
-        is_emptyset:=(i=32);
-      end;
-
-
-{*****************************************************************************
-                              Case Helpers
-*****************************************************************************}
-
-    function case_count_labels(root : pcaserecord) : longint;
-      var
-         _l : longint;
-
-      procedure count(p : pcaserecord);
-        begin
-           inc(_l);
-           if assigned(p^.less) then
-             count(p^.less);
-           if assigned(p^.greater) then
-             count(p^.greater);
-        end;
-
-      begin
-         _l:=0;
-         count(root);
-         case_count_labels:=_l;
-      end;
-
-
-    function case_get_max(root : pcaserecord) : longint;
-      var
-         hp : pcaserecord;
-      begin
-         hp:=root;
-         while assigned(hp^.greater) do
-           hp:=hp^.greater;
-         case_get_max:=hp^._high;
-      end;
-
-
-    function case_get_min(root : pcaserecord) : longint;
-      var
-         hp : pcaserecord;
-      begin
-         hp:=root;
-         while assigned(hp^.less) do
-           hp:=hp^.less;
-         case_get_min:=hp^._low;
-      end;
-
-{$ifdef newcg}
-{$I node.inc}
-{$endif newcg}
-end.
-{
-  $Log$
-  Revision 1.1  2000-10-14 10:14:58  peter
-    * moehrendorf oct 2000 rewrite
-
-  Revision 1.11  2000/10/01 19:48:25  peter
-    * lot of compile updates for cg11
-
-  Revision 1.10  2000/09/27 18:14:31  florian
-    * fixed a lot of syntax errors in the n*.pas stuff
-
-  Revision 1.9  2000/09/24 15:06:32  peter
-    * use defines.inc
-
-  Revision 1.8  2000/08/27 16:11:55  peter
-    * moved some util functions from globals,cobjects to cutils
-    * splitted files into finput,fmodule
-
-  Revision 1.7  2000/08/17 12:03:48  florian
-    * fixed several problems with the int64 constants
-
-  Revision 1.6  2000/08/16 13:06:07  florian
-    + support of 64 bit integer constants
-
-  Revision 1.5  2000/08/12 06:46:51  florian
-    + case statement for int64/qword implemented
-
-  Revision 1.4  2000/08/06 19:39:28  peter
-    * default parameters working !
-
-  Revision 1.3  2000/08/04 22:00:52  peter
-    * merges from fixes
-
-  Revision 1.2  2000/07/13 11:32:52  michael
-  + removed logs
-}

compiler/tokendat.pas

@@ -1,76 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2000 by Daniel Mantione, Peter Vreman
-    Members of the Free Pascal development team
-
-    This little program generates a file of tokendata
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-program tokendat;
-
-{$ifdef FPC}
-  {$FATAL Use tp 7 to compile, FPC can't be used because the records are written different.}
-{$else}
-  {$ifndef TP}
-    -- You need to define -dTP and -dI386
-  {$endif}
-  {$ifndef I386}
-    -- You need to define -dTP and -dI386
-  {$endif}
-{$endif}
-
-uses    tokens;
-
-{Header is designed both to identify the file and to display a nice
- message when you use the type command on it.
-
-Explanation:
-
-#8      String length is also displayed. A backspace erases it.
-#13#10  Needed to display dos prompt on next line.
-#26     End of file. Causes type to stop reading the file.
-}
-
-const
-  headerstr:string[length(tokheader)]=tokheader;
-var
-  f:file;
-  a:longint;
-begin
-    new(tokenidx);
-    create_tokenidx;
-    assign(f,'tokens.dat');
-    rewrite(f,1);
-    {Write header...}
-    blockwrite(f,headerstr,sizeof(headerstr));
-    {Write size of tokeninfo.}
-    a:=sizeof(arraytokeninfo);
-    blockwrite(f,a,sizeof(a));
-    {Write tokeninfo.}
-    blockwrite(f,arraytokeninfo,sizeof(arraytokeninfo));
-    {Write tokenindex.}
-    blockwrite(f,tokenidx^,sizeof(tokenidx^));
-    close(f);
-    dispose(tokenidx);
-end.
-{
-  $Log$
-  Revision 1.2  2000-07-13 11:32:52  michael
-  + removed logs
-
-}