fpc/compiler/rautils.pas

{
    Copyright (c) 1998-2002 by Carl Eric Codere and Peter Vreman

    This unit implements some support routines for assembler parsing
    independent of the processor

    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 RAUtils;

{$i fpcdefs.inc}

Interface

Uses
  cutils,cclasses,
  globtype,aasmbase,aasmtai,aasmdata,cpubase,cpuinfo,cgbase,cgutils,
  symconst,symbase,symtype,symdef,symsym;

Const
  RPNMax = 10;             { I think you only need 4, but just to be safe }
  OpMax  = 25;

{---------------------------------------------------------------------
                       Local Label Management
---------------------------------------------------------------------}

Type
  { Each local label has this structure associated with it }
  TLocalLabel = class(TFPHashObject)
    Emitted : boolean;
    constructor Create(AList:TFPHashObjectList;const n:string);
    function  Gettasmlabel:tasmlabel;
  private
    lab : tasmlabel;
  end;

  TLocalLabelList = class(TFPHashObjectList)
    procedure CheckEmitted;
  end;

var
  LocalLabelList : TLocalLabelList;

function CreateLocalLabel(const s: string; var hl: tasmlabel; emit:boolean):boolean;
Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;


{---------------------------------------------------------------------
                 Instruction management
---------------------------------------------------------------------}

type
  TOprType=(OPR_NONE,OPR_CONSTANT,OPR_SYMBOL,OPR_LOCAL,
            OPR_REFERENCE,OPR_REGISTER,OPR_REGLIST,OPR_COND,OPR_REGSET,OPR_SHIFTEROP,OPR_MODEFLAGS,OPR_COH,OPR_REGISTERSELECTOR);

  TOprRec = record
    case typ:TOprType of
      OPR_NONE      : ();
      OPR_CONSTANT  : (val:aint);
      OPR_SYMBOL    : (symbol:tasmsymbol;symofs:aint);
      OPR_REFERENCE : (ref:treference);
      OPR_LOCAL     : (localsym:tabstractnormalvarsym;localsymofs:aint;localindexreg:tregister;localscale:byte;localgetoffset,localforceref:boolean);
      OPR_REGISTER  : (reg:tregister);
{$ifdef m68k}
      OPR_REGLIST   : (regset : tcpuregisterset);
{$endif m68k}
{$ifdef powerpc}
      OPR_COND      : (cond : tasmcond);
{$endif powerpc}
{$ifdef POWERPC64}
      OPR_COND      : (cond : tasmcond);
{$endif POWERPC64}
{$ifdef arm}
      OPR_REGSET    : (regset : tcpuregisterset; regtype: tregistertype; subreg: tsubregister);
      OPR_SHIFTEROP : (shifterop : tshifterop);
      OPR_COND      : (cc : tasmcond);
      OPR_MODEFLAGS : (flags : tcpumodeflags);
{$endif arm}
{$ifdef avr32}
      OPR_REGSET    : (regset : tcpuregisterset; regtype: tregistertype; subreg: tsubregister);
      OPR_SHIFTEROP : (shifterop : tshifterop);
      OPR_COH       : ();
      OPR_REGISTERSELECTOR : (topreg : tregister; selector : tregisterselector);
{$endif avr32}
  end;

  TOperand = class
    typesize : aint;
    hastype,          { if the operand has typecasted variable }
    hasvar : boolean; { if the operand is loaded with a variable }
    size   : TCGSize;
    opr    : TOprRec;
    constructor create;virtual;
    destructor  destroy;override;
    Procedure SetSize(_size:longint;force:boolean);virtual;
    Procedure SetCorrectSize(opcode:tasmop);virtual;
    Function  SetupResult:boolean;virtual;
    Function  SetupSelf:boolean;
    Function  SetupOldEBP:boolean;
    Function  SetupVar(const s:string;GetOffset : boolean): Boolean;
    Function  CheckOperand: boolean; virtual;
    Procedure InitRef;
  end;
  TCOperand = class of TOperand;

  TInstruction = class
    opcode    : tasmop;
    condition : tasmcond;
    ops       : byte;
    labeled   : boolean;
    operands  : array[1..max_operands] of toperand;
    constructor create(optype : tcoperand);virtual;
    destructor  destroy;override;
    { converts the instruction to an instruction how it's used by the assembler writer
      and concats it to the passed list. The newly created item is returned if the
      instruction was valid, otherwise nil is returned }
    function ConcatInstruction(p:TAsmList) : tai;virtual;
    Procedure Swapoperands;
  end;

  {---------------------------------------------------------------------}
  {                   Expression parser types                           }
  {---------------------------------------------------------------------}

   TExprOperator = record
    ch: char;           { operator }
    is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not }
   end;

  {**********************************************************************}
  { The following operators are supported:                              }
  {  '+' : addition                                                     }
  {  '-' : subtraction                                                  }
  {  '*' : multiplication                                               }
  {  '/' : modulo division                                              }
  {  '^' : exclusive or                                                 }
  {  '<' : shift left                                                   }
  {  '>' : shift right                                                  }
  {  '&' : bitwise and                                                  }
  {  '|' : bitwise or                                                   }
  {  '~' : bitwise complement                                           }
  {  '%' : modulo division                                              }
  {  nnn: longint numbers                                               }
  {  ( and ) parenthesis                                                }
  {**********************************************************************}

  TExprParse = class
    public
     Constructor create;
     Destructor Destroy;override;
     Function Evaluate(Expr:  String): aint;
     Function Priority(_Operator: Char): aint;
    private
     RPNStack   : Array[1..RPNMax] of aint;        { Stack For RPN calculator }
     RPNTop     : aint;
     OpStack    : Array[1..OpMax] of TExprOperator;    { Operator stack For conversion }
     OpTop      : aint;
     Procedure RPNPush(Num: aint);
     Function RPNPop: aint;
     Procedure RPNCalc(const token: String; prefix: boolean);
     Procedure OpPush(_Operator: char; prefix: boolean);
     { In reality returns TExprOperaotr }
     Procedure OpPop(var _Operator:TExprOperator);
  end;

  { Evaluate an expression string to a aint }
  Function CalculateExpression(const expression: string): aint;

  {---------------------------------------------------------------------}
  {                     String routines                                 }
  {---------------------------------------------------------------------}

Function ParseVal(const S:String;base:byte):aint;
Function PadZero(Var s: String; n: byte): Boolean;
Function EscapeToPascal(const s:string): string;

{---------------------------------------------------------------------
                     Symbol helper routines
---------------------------------------------------------------------}

procedure AsmSearchSym(const s:string;var srsym:tsym;var srsymtable:TSymtable);
Function GetRecordOffsetSize(s:string;Var Offset: aint;var Size:aint; var mangledname: string; needvmtofs: boolean):boolean;
Function SearchType(const hs:string;var size:aint): Boolean;
Function SearchRecordType(const s:string): boolean;
Function SearchIConstant(const s:string; var l:aint): boolean;


{---------------------------------------------------------------------
                  Instruction generation routines
---------------------------------------------------------------------}

  Procedure ConcatPasString(p : TAsmList;s:string);
  Procedure ConcatLabel(p: TAsmList;var l : tasmlabel);
  Procedure ConcatConstant(p : TAsmList;value: aint; constsize:byte);
  Procedure ConcatConstSymbol(p : TAsmList;const sym:string;symtyp:tasmsymtype;l:aint);
  Procedure ConcatRealConstant(p : TAsmList;value: bestreal; real_typ : tfloattype);
  Procedure ConcatString(p : TAsmList;s:string);
  procedure ConcatAlign(p:TAsmList;l:aint);
  Procedure ConcatPublic(p:TAsmList;const s : string);
  Procedure ConcatLocal(p:TAsmList;const s : string);


Implementation

uses
  SysUtils,
  defutil,systems,verbose,globals,
  symtable,paramgr,
  aasmcpu,
  procinfo;

{*************************************************************************
                              TExprParse
*************************************************************************}

Constructor TExprParse.create;
Begin
end;


Procedure TExprParse.RPNPush(Num : aint);
{ Add an operand to the top of the RPN stack }
begin
  if RPNTop < RPNMax then
   begin
     Inc(RPNTop);
     RPNStack[RPNTop]:=Num;
   end
  else
   Message(asmr_e_expr_illegal);
end;


Function TExprParse.RPNPop : aint;
{ Get the operand at the top of the RPN stack }
begin
  if RPNTop > 0 then
   begin
     RPNPop:=RPNStack[RPNTop];
     Dec(RPNTop);
   end
  else
   Message(asmr_e_expr_illegal);
end;


Procedure TExprParse.RPNCalc(const Token : String; prefix:boolean);                       { RPN Calculator }
Var
  Temp  : aint;
  n1,n2 : aint;
  LocalError : Integer;
begin
  { Handle operators }
  if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then
   Case Token[1] of
    '+' :
      Begin
        if not prefix then
         RPNPush(RPNPop + RPNPop);
      end;
    '-' :
      Begin
        if prefix then
         RPNPush(-(RPNPop))
        else
         begin
           n1:=RPNPop;
           n2:=RPNPop;
           RPNPush(n2 - n1);
         end;
      end;
    '*' : RPNPush(RPNPop * RPNPop);
    '&' :
      begin
        n1:=RPNPop;
        n2:=RPNPop;
        RPNPush(n2 and n1);
      end;
    '|' :
      begin
        n1:=RPNPop;
        n2:=RPNPop;
        RPNPush(n2 or n1);
      end;
    '~' : RPNPush(NOT RPNPop);
    '<' :
      begin
        n1:=RPNPop;
        n2:=RPNPop;
        RPNPush(n2 SHL n1);
      end;
    '>' :
      begin
        n1:=RPNPop;
        n2:=RPNPop;
        RPNPush(n2 SHR n1);
      end;
    '%' :
      begin
        Temp:=RPNPop;
        if Temp <> 0 then
         RPNPush(RPNPop mod Temp)
        else
         begin
           Message(asmr_e_expr_zero_divide);
           { push 1 for error recovery }
           RPNPush(1);
         end;
      end;
    '^' : RPNPush(RPNPop XOR RPNPop);
    '/' :
      begin
        Temp:=RPNPop;
        if Temp <> 0 then
         RPNPush(RPNPop div Temp)
        else
         begin
           Message(asmr_e_expr_zero_divide);
           { push 1 for error recovery }
           RPNPush(1);
         end;
      end;
   end
  else
   begin
     { Convert String to number and add to stack }
      Val(Token, Temp, LocalError);
     if LocalError = 0 then
      RPNPush(Temp)
     else
      begin
        Message(asmr_e_expr_illegal);
        { push 1 for error recovery }
        RPNPush(1);
      end;
   end;
end;


Procedure TExprParse.OpPush(_Operator : char;prefix: boolean);
{ Add an operator onto top of the stack }
begin
  if OpTop < OpMax then
   begin
     Inc(OpTop);
     OpStack[OpTop].ch:=_Operator;
     OpStack[OpTop].is_prefix:=prefix;
   end
  else
   Message(asmr_e_expr_illegal);
end;


Procedure TExprParse.OpPop(var _Operator:TExprOperator);
{ Get operator at the top of the stack }
begin
  if OpTop > 0 then
   begin
     _Operator:=OpStack[OpTop];
     Dec(OpTop);
   end
  else
   Message(asmr_e_expr_illegal);
end;


Function TExprParse.Priority(_Operator : Char) : aint;
{ Return priority of operator }
{ The greater the priority, the higher the precedence }
begin
  Case _Operator OF
    '(' :
      Priority:=0;
    '|','^','~' :             // the lowest priority: OR, XOR, NOT
      Priority:=0;
    '&' :                     // bigger priority: AND
      Priority:=1;
    '+', '-' :                // bigger priority: +, -
      Priority:=2;
    '*', '/','%','<','>' :   // the highest priority: *, /, MOD, SHL, SHR
      Priority:=3;
    else
      Message(asmr_e_expr_illegal);
  end;
end;


Function TExprParse.Evaluate(Expr : String):aint;
Var
  I     : longint;
  Token : String;
  opr   : TExprOperator;
begin
  Evaluate:=0;
  { Reset stacks }
  OpTop :=0;
  RPNTop:=0;
  Token :='';
  { nothing to do ? }
  if Expr='' then
   exit;
  For I:=1 to Length(Expr) DO
   begin
     if Expr[I] in ['0'..'9'] then
      begin       { Build multi-digit numbers }
        Token:=Token + Expr[I];
        if I = Length(Expr) then          { Send last one to calculator }
         RPNCalc(Token,false);
      end
     else
      if Expr[I] in ['+', '-', '*', '/', '(', ')','^','&','|','%','~','<','>'] then
       begin
         if Token <> '' then
          begin        { Send last built number to calc. }
            RPNCalc(Token,false);
            Token:='';
          end;

         Case Expr[I] OF
          '(' : OpPush('(',false);
          ')' : begin
                  While (OpTop>0) and (OpStack[OpTop].ch <> '(') DO
                   Begin
                     OpPop(opr);
                     RPNCalc(opr.ch,opr.is_prefix);
                   end;
                  OpPop(opr);                          { Pop off and ignore the '(' }
                end;
  '+','-','~' : Begin
                  { workaround for -2147483648 }
                  if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then
                   begin
                     token:='-';
                     expr[i]:='+';
                   end;
                  { if start of expression then surely a prefix }
                  { or if previous char was also an operator    }
                  if (I = 1) or (not (Expr[I-1] in ['0'..'9',')'])) then
                    OpPush(Expr[I],true)
                  else
                    Begin
                    { Evaluate all higher priority operators }
                      While (OpTop > 0) AND (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
                       Begin
                         OpPop(opr);
                         RPNCalc(opr.ch,opr.is_prefix);
                       end;
                      OpPush(Expr[I],false);
                    End;
                end;
     '*', '/',
  '^','|','&',
  '%','<','>' : begin
                  While (OpTop > 0) and (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
                   Begin
                     OpPop(opr);
                     RPNCalc(opr.ch,opr.is_prefix);
                   end;
                  OpPush(Expr[I],false);
                end;
         end; { Case }
       end
     else
      Message(asmr_e_expr_illegal);  { Handle bad input error }
   end;

{ Pop off the remaining operators }
  While OpTop > 0 do
   Begin
     OpPop(opr);
     RPNCalc(opr.ch,opr.is_prefix);
   end;

{ The result is stored on the top of the stack }
  Evaluate:=RPNPop;
end;


Destructor TExprParse.Destroy;
Begin
end;


Function CalculateExpression(const expression: string): aint;
var
  expr: TExprParse;
Begin
  expr:=TExprParse.create;
  CalculateExpression:=expr.Evaluate(expression);
  expr.Free;
end;


{*************************************************************************}
{                         String conversions/utils                        }
{*************************************************************************}

Function EscapeToPascal(const s:string): string;
{ converts a C styled string - which contains escape }
{ characters to a pascal style string.               }
var
  i,len : aint;
  hs    : string;
  temp  : string;
  c     : char;
Begin
  hs:='';
  len:=0;
  i:=0;
  while (i<length(s)) and (len<255) do
   begin
     Inc(i);
     if (s[i]='\') and (i<length(s)) then
      Begin
        inc(i);
        case s[i] of
         '\' :
           c:='\';
         'b':
           c:=#8;
         'f':
           c:=#12;
         'n':
           c:=#10;
         'r':
           c:=#13;
         't':
           c:=#9;
         '"':
           c:='"';
         '0'..'7':
           Begin
             temp:=s[i];
             temp:=temp+s[i+1];
             temp:=temp+s[i+2];
             inc(i,2);
             c:=chr(ParseVal(temp,8));
           end;
         'x':
           Begin
             temp:=s[i+1];
             temp:=temp+s[i+2];
             inc(i,2);
             c:=chr(ParseVal(temp,16));
           end;
         else
           Begin
             Message1(asmr_e_escape_seq_ignored,s[i]);
             c:=s[i];
           end;
        end;
      end
     else
      c:=s[i];
     inc(len);
     hs[len]:=c;
   end;
  hs[0]:=chr(len);
  EscapeToPascal:=hs;
end;


Function ParseVal(const S:String;base:byte):aint;
{ Converts a decimal string to aint }
var
  code : integer;
  errmsg : word;
  prefix : string[2];
Begin
  case base of
    2 :
      begin
        errmsg:=asmr_e_error_converting_binary;
        prefix:='%';
      end;
    8 :
      begin
        errmsg:=asmr_e_error_converting_octal;
        prefix:='&';
      end;
    10 :
      begin
        errmsg:=asmr_e_error_converting_decimal;
        prefix:='';
      end;
    16 :
      begin
        errmsg:=asmr_e_error_converting_hexadecimal;
        prefix:='$';
      end;
    else
      internalerror(200501202);
  end;
  val(prefix+s,result,code);
  if code<>0 then
    begin
      val(prefix+s,aword(result),code);
      if code<>0 then
        begin
          Message1(errmsg,s);
          result:=0;
        end;
    end;
end;


Function PadZero(Var s: String; n: byte): Boolean;
Begin
  PadZero:=TRUE;
  { Do some error checking first }
  if Length(s) = n then
    exit
  else
  if Length(s) > n then
  Begin
    PadZero:=FALSE;
    delete(s,n+1,length(s));
    exit;
  end
  else
    PadZero:=TRUE;
  { Fill it up with the specified character }
  fillchar(s[length(s)+1],n-1,#0);
  s[0]:=chr(n);
end;


{****************************************************************************
                                   TOperand
****************************************************************************}

constructor TOperand.Create;
begin
  size:=OS_NO;
  hastype:=false;
  hasvar:=false;
  FillChar(Opr,sizeof(Opr),0);
end;


destructor TOperand.destroy;
begin
end;


Procedure TOperand.SetSize(_size:longint;force:boolean);
begin
  if force or
     ((size = OS_NO) and (_size<=16)) then
   Begin
     case _size of
        1 : size:=OS_8;
        2 : size:=OS_16{ could be S_IS};
        4 : size:=OS_32{ could be S_IL or S_FS};
        8 : size:=OS_64{ could be S_D or S_FL};
       10 : size:=OS_F80;
       16 : size:=OS_128;
     end;
   end;
end;


Procedure TOperand.SetCorrectSize(opcode:tasmop);
begin
end;


function TOperand.SetupResult:boolean;

begin
  SetupResult:=false;
  { replace by correct offset. }
  with current_procinfo.procdef do
    if (not is_void(returndef)) then
      begin
        if (m_tp7 in current_settings.modeswitches) and
          (not paramanager.ret_in_param(returndef,proccalloption)) then
          begin
            message(asmr_e_cannot_use_RESULT_here);
            exit;
          end;
        SetupResult:=setupvar('result',false)
      end
    else
      message(asmr_e_void_function);
end;


Function TOperand.SetupSelf:boolean;
Begin
  SetupSelf:=false;
  if assigned(current_structdef) then
    SetupSelf:=setupvar('self',false)
  else
    Message(asmr_e_cannot_use_SELF_outside_a_method);
end;


Function TOperand.SetupOldEBP:boolean;
Begin
  SetupOldEBP:=false;
  if current_procinfo.procdef.parast.symtablelevel>normal_function_level then
    SetupOldEBP:=setupvar('parentframe',false)
  else
    Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
end;


Function TOperand.SetupVar(const s:string;GetOffset : boolean): Boolean;

  function symtable_has_localvarsyms(st:TSymtable):boolean;
  var
    sym : tsym;
    i   : longint;
  begin
    result:=false;
    for i:=0 to st.SymList.Count-1 do
      begin
        sym:=tsym(st.SymList[i]);
        if sym.typ=localvarsym then
          begin
            result:=true;
            exit;
          end;
      end;
  end;

  procedure setconst(l:aint);
  begin
    { We return the address of the field, just like Delphi/TP }
    case opr.typ of
      OPR_NONE :
        begin
          opr.typ:=OPR_CONSTANT;
          opr.val:=l;
        end;
      OPR_CONSTANT :
        inc(opr.val,l);
      OPR_REFERENCE :
        inc(opr.ref.offset,l);
      OPR_LOCAL :
        inc(opr.localsymofs,l);
      else
        Message(asmr_e_invalid_operand_type);
    end;
  end;


{ search and sets up the correct fields in the Instr record }
{ for the NON-constant identifier passed to the routine.    }
{ if not found returns FALSE.                               }
var
  sym : tsym;
  srsymtable : TSymtable;
  harrdef : tarraydef;
  indexreg : tregister;
  l : aint;
  plist : ppropaccesslistitem;
Begin
  SetupVar:=false;
  asmsearchsym(s,sym,srsymtable);
  if sym = nil then
   exit;
  if sym.typ=absolutevarsym then
    begin
      if (tabsolutevarsym(sym).abstyp=tovar) then
        begin
          { Only support simple loads }
          plist:=tabsolutevarsym(sym).ref.firstsym;
          if assigned(plist) and
             (plist^.sltype=sl_load) then
            sym:=plist^.sym
          else
            begin
              Message(asmr_e_unsupported_symbol_type);
              exit;
            end;
        end
      else
        begin
          Message(asmr_e_unsupported_symbol_type);
          exit;
        end;
    end;
  case sym.typ of
    fieldvarsym :
      begin
        if not tabstractrecordsymtable(sym.owner).is_packed then
          setconst(tfieldvarsym(sym).fieldoffset)
        else if tfieldvarsym(sym).fieldoffset mod 8 = 0 then
          setconst(tfieldvarsym(sym).fieldoffset div 8)
        else
          Message(asmr_e_packed_element);
        hasvar:=true;
        SetupVar:=true;
      end;
    staticvarsym,
    localvarsym,
    paravarsym :
      begin
        { we always assume in asm statements that     }
        { that the variable is valid.                 }
        tabstractvarsym(sym).varstate:=vs_readwritten;
        inc(tabstractvarsym(sym).refs);
        { variable can't be placed in a register }
        tabstractvarsym(sym).varregable:=vr_none;
        { and anything may happen with its address }
        tabstractvarsym(sym).addr_taken:=true;
        case sym.typ of
          staticvarsym :
            begin
              initref;
              opr.ref.symbol:=current_asmdata.RefAsmSymbol(tstaticvarsym(sym).mangledname);
            end;
          paravarsym,
          localvarsym :
            begin
              if opr.typ=OPR_REFERENCE then
                begin
                  indexreg:=opr.ref.base;
                  if opr.ref.index<>NR_NO then
                    begin
                      if indexreg=NR_NO then
                        indexreg:=opr.ref.index
                      else
                        Message(asmr_e_multiple_index);
                    end;
                end
              else
                indexreg:=NR_NO;
              opr.typ:=OPR_LOCAL;
              if assigned(current_procinfo.parent) and
                 not(po_inline in current_procinfo.procdef.procoptions) and
                 (sym.owner<>current_procinfo.procdef.localst) and
                 (sym.owner<>current_procinfo.procdef.parast) and
                 (current_procinfo.procdef.localst.symtablelevel>normal_function_level) and
                 symtable_has_localvarsyms(current_procinfo.procdef.localst) then
                message1(asmr_e_local_para_unreachable,s);
              opr.localsym:=tabstractnormalvarsym(sym);
              opr.localsymofs:=0;
              opr.localindexreg:=indexreg;
              opr.localscale:=0;
              opr.localgetoffset:=GetOffset;
              if paramanager.push_addr_param(tabstractvarsym(sym).varspez,tabstractvarsym(sym).vardef,current_procinfo.procdef.proccalloption) then
                SetSize(sizeof(pint),false);
            end;
        end;
        case tabstractvarsym(sym).vardef.typ of
          orddef,
          enumdef,
          pointerdef,
          floatdef :
            SetSize(tabstractvarsym(sym).getsize,false);
          arraydef :
            begin
              { for arrays try to get the element size, take care of
                multiple indexes }
              harrdef:=tarraydef(tabstractvarsym(sym).vardef);
              while assigned(harrdef.elementdef) and
                    (harrdef.elementdef.typ=arraydef) do
               harrdef:=tarraydef(harrdef.elementdef);
              if not is_packed_array(harrdef) then
                SetSize(harrdef.elesize,false)
               else
                 begin
                   if (harrdef.elepackedbitsize mod 8) = 0 then
                     SetSize(harrdef.elepackedbitsize div 8,false)
                 end;
            end;
        end;
        hasvar:=true;
        SetupVar:=true;
        Exit;
      end;
    constsym :
      begin
        if tconstsym(sym).consttyp=constord then
         begin
           setconst(tconstsym(sym).value.valueord.svalue);
           SetupVar:=true;
           Exit;
         end;
      end;
    typesym :
      begin
        if ttypesym(sym).typedef.typ in [recorddef,objectdef] then
         begin
           setconst(0);
           SetupVar:=TRUE;
           Exit;
         end;
      end;
    procsym :
      begin
        if opr.typ<>OPR_NONE then
          Message(asmr_e_invalid_operand_type);
        if Tprocsym(sym).ProcdefList.Count>1 then
          Message(asmr_w_calling_overload_func);
        l:=opr.ref.offset;
        opr.typ:=OPR_SYMBOL;
        opr.symbol:=current_asmdata.RefAsmSymbol(tprocdef(tprocsym(sym).ProcdefList[0]).mangledname);
        opr.symofs:=l;
        hasvar:=true;
        SetupVar:=TRUE;
        Exit;
      end;
    else
      begin
        Message(asmr_e_unsupported_symbol_type);
        exit;
      end;
  end;
end;


procedure TOperand.InitRef;
{*********************************************************************}
{  Description: This routine first check if the opcode is of     }
{  type OPR_NONE, or OPR_REFERENCE , if not it gives out an error.    }
{  If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up  }
{  the operand type to OPR_REFERENCE, as well as setting up the ref   }
{  to point to the default segment.                                   }
{*********************************************************************}
var
  l : aint;
  hsymofs : aint;
  hsymbol : tasmsymbol;
  reg : tregister;
Begin
  case opr.typ of
    OPR_REFERENCE :
      exit;
    OPR_CONSTANT :
      begin
        l:=opr.val;
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
        opr.Ref.Offset:=l;
      end;
    OPR_NONE :
      begin
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
      end;
    OPR_REGISTER :
      begin
        reg:=opr.reg;
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
        opr.Ref.base:=reg;
      end;
    OPR_SYMBOL :
      begin
        hsymbol:=opr.symbol;
        hsymofs:=opr.symofs;
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
        opr.ref.symbol:=hsymbol;
        opr.ref.offset:=hsymofs;
      end;
    else
      begin
        Message(asmr_e_invalid_operand_type);
        { Recover }
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
      end;
  end;
end;

Function TOperand.CheckOperand: boolean;
{*********************************************************************}
{  Description: This routine checks if the operand is of              }
{  valid, and returns false if it isn't. Does nothing by default.     }
{*********************************************************************}
begin
  result:=true;
end;


{****************************************************************************
                                 TInstruction
****************************************************************************}

constructor TInstruction.create(optype : tcoperand);
  var
    i : longint;
  Begin
    { these field are set to 0 anyways by the constructor helper (FK)
    Opcode:=A_NONE;
    Condition:=C_NONE;
    Ops:=0;
    }
    for i:=1 to max_operands do
      Operands[i]:=optype.create;
    Labeled:=false;
  end;


destructor TInstruction.destroy;
var
  i : longint;
Begin
  for i:=1 to max_operands do
   Operands[i].free;
end;


  Procedure TInstruction.Swapoperands;
    Var
      p : toperand;
    Begin
      case Ops of
       2 :
        begin
          p:=Operands[1];
          Operands[1]:=Operands[2];
          Operands[2]:=p;
        end;
       3 :
        begin
          p:=Operands[1];
          Operands[1]:=Operands[3];
          Operands[3]:=p;
        end;
      end;
    end;


  function TInstruction.ConcatInstruction(p:TAsmList) : tai;
    var
      ai   : taicpu;
      i : longint;
    begin
      for i:=1 to Ops do
        operands[i].CheckOperand;

      ai:=taicpu.op_none(opcode);
      ai.Ops:=Ops;
      ai.Allocate_oper(Ops);
      for i:=1 to Ops do
        with operands[i].opr do
          begin
            case typ of
              OPR_CONSTANT :
                ai.loadconst(i-1,val);
              OPR_REGISTER:
                ai.loadreg(i-1,reg);
              OPR_SYMBOL:
                ai.loadsymbol(i-1,symbol,symofs);
              OPR_LOCAL :
                ai.loadlocal(i-1,localsym,localsymofs,localindexreg,
                             localscale,localgetoffset,localforceref);
              OPR_REFERENCE:
                ai.loadref(i-1,ref);
{$ifdef ARM}
              OPR_REGSET:
                ai.loadregset(i-1,regtype,subreg,regset);
              OPR_SHIFTEROP:
                ai.loadshifterop(i-1,shifterop);
              OPR_COND:
                ai.loadconditioncode(i-1,cc);
              OPR_MODEFLAGS:
                ai.loadmodeflags(i-1,flags);
{$endif ARM}
{$ifdef AVR32}
              OPR_REGSET:
                ai.loadregset(i-1,regtype,subreg,regset);
              OPR_SHIFTEROP:
                ai.loadshifterop(i-1,shifterop);
              OPR_COH:
                ai.loadCOH(i-1);
              OPR_REGISTERSELECTOR:
                ai.loadregisterselector(i-1,topreg,selector);
{$endif AVR32}
              { ignore wrong operand }
              OPR_NONE:
                ;
              else
                internalerror(200501051);
            end;
          end;
     ai.SetCondition(condition);
     { Concat the opcode or give an error }
      if assigned(ai) then
         p.concat(ai)
      else
       Message(asmr_e_invalid_opcode_and_operand);
      result:=ai;
    end;


{***************************************************************************
                                 TLocalLabel
***************************************************************************}

constructor TLocalLabel.create(AList:TFPHashObjectList;const n:string);
begin
  inherited Create(AList,n);
  lab:=nil;
  emitted:=false;
end;


function TLocalLabel.Gettasmlabel:tasmlabel;
begin
  if not assigned(lab) then
   begin
     current_asmdata.getjumplabel(lab);
     { this label is forced to be used so it's always written }
     lab.increfs;
   end;
  Gettasmlabel:=lab;
end;


{***************************************************************************
                             TLocalLabelList
***************************************************************************}

procedure TLocalLabelList.CheckEmitted;
var
  i : longint;
  lab : TLocalLabel;
begin
  for i:=0 to LocalLabelList.Count-1 do
    begin
      lab:=TLocalLabel(LocalLabelList[i]);
      if not lab.emitted then
        Message1(asmr_e_unknown_label_identifier,lab.name);
    end;
end;


function CreateLocalLabel(const s: string; var hl: tasmlabel; emit:boolean):boolean;
var
  lab : TLocalLabel;
Begin
  CreateLocalLabel:=true;
{ Check if it already is defined }
  lab:=TLocalLabel(LocalLabellist.Find(s));
  if not assigned(lab) then
    lab:=TLocalLabel.Create(LocalLabellist,s);
{ set emitted flag and check for dup syms }
  if emit then
   begin
     if lab.Emitted then
      begin
        Message1(asmr_e_dup_local_sym,lab.Name);
        CreateLocalLabel:=false;
      end;
     lab.Emitted:=true;
   end;
  hl:=lab.Gettasmlabel;
end;


{****************************************************************************
                      Symbol table helper routines
****************************************************************************}

procedure AsmSearchSym(const s:string;var srsym:tsym;var srsymtable:TSymtable);
var
  i : integer;
begin
  i:=pos('.',s);
  { allow unit.identifier }
  if i>0 then
    begin
      searchsym(Copy(s,1,i-1),srsym,srsymtable);
      if assigned(srsym) then
       begin
         if (srsym.typ=unitsym) and
            (srsym.owner.symtabletype in [staticsymtable,globalsymtable]) and
            srsym.owner.iscurrentunit then
           searchsym_in_module(tunitsym(srsym).module,Copy(s,i+1,255),srsym,srsymtable)
         else
           begin
             srsym:=nil;
             srsymtable:=nil;
           end;
       end;
    end
  else
    searchsym(s,srsym,srsymtable);
end;


Function SearchType(const hs:string;var size:aint): Boolean;
var
  srsym : tsym;
  srsymtable : TSymtable;
begin
  result:=false;
  size:=0;
  asmsearchsym(hs,srsym,srsymtable);
  if assigned(srsym) and
     (srsym.typ=typesym) then
    begin
      size:=ttypesym(srsym).typedef.size;
      result:=true;
    end;
end;



Function SearchRecordType(const s:string): boolean;
var
  srsym : tsym;
  srsymtable : TSymtable;
Begin
  SearchRecordType:=false;
{ Check the constants in symtable }
  asmsearchsym(s,srsym,srsymtable);
  if srsym <> nil then
   Begin
     case srsym.typ of
       typesym :
         begin
           if ttypesym(srsym).typedef.typ in [recorddef,objectdef] then
            begin
              SearchRecordType:=true;
              exit;
            end;
         end;
       fieldvarsym :
         begin
           if (tfieldvarsym(srsym).vardef.typ in [recorddef,objectdef]) then
             begin
               SearchRecordType:=true;
               exit;
             end;
         end;
     end;
   end;
end;


Function SearchIConstant(const s:string; var l:aint): boolean;
{**********************************************************************}
{  Description: Searches for a CONSTANT of name s in either the local  }
{  symbol list, then in the global symbol list, and returns the value  }
{  of that constant in l. Returns TRUE if successfull, if not found,   }
{  or if the constant is not of correct type, then returns FALSE       }
{ Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
{  respectively.                                                       }
{**********************************************************************}
var
  srsym : tsym;
  srsymtable : TSymtable;
Begin
  SearchIConstant:=false;
{ check for TRUE or FALSE reserved words first }
  if s = 'TRUE' then
   Begin
     SearchIConstant:=TRUE;
     l:=1;
     exit;
   end;
  if s = 'FALSE' then
   Begin
     SearchIConstant:=TRUE;
     l:=0;
     exit;
   end;
{ Check the constants in symtable }
  asmsearchsym(s,srsym,srsymtable);
  if srsym <> nil then
   Begin
     case srsym.typ of
       constsym :
         begin
           if tconstsym(srsym).consttyp=constord then
            Begin
              l:=tconstsym(srsym).value.valueord.svalue;
              SearchIConstant:=TRUE;
              exit;
            end;
         end;
       enumsym:
         Begin
           l:=tenumsym(srsym).value;
           SearchIConstant:=TRUE;
           exit;
         end;
     end;
   end;
end;


Function GetRecordOffsetSize(s:string;Var Offset: aint;var Size:aint; var mangledname: string; needvmtofs: boolean):boolean;
{ search and returns the offset and size of records/objects of the base }
{ with field name setup in field.                              }
{ returns FALSE if not found.                                  }
{ used when base is a variable or a typed constant name.       }
var
  st   : TSymtable;
  harrdef : tarraydef;
  sym  : tsym;
  srsymtable : TSymtable;
  i    : longint;
  base : string;
  procdef: tprocdef;
Begin
  GetRecordOffsetSize:=FALSE;
  Offset:=0;
  Size:=0;
  mangledname:='';
  i:=pos('.',s);
  if i=0 then
   i:=255;
  base:=Copy(s,1,i-1);
  delete(s,1,i);
  if base='SELF' then
   st:=current_structdef.symtable
  else
   begin
     asmsearchsym(base,sym,srsymtable);
     st:=nil;
     { we can start with a var,type,typedconst }
     if assigned(sym) then
       case sym.typ of
         staticvarsym,
         localvarsym,
         paravarsym :
           st:=Tabstractvarsym(sym).vardef.GetSymtable(gs_record);
         typesym :
           st:=Ttypesym(sym).typedef.GetSymtable(gs_record);
       end
     else
       s:='';
   end;
  { now walk all recordsymtables }
  while assigned(st) and (s<>'') do
   begin
     { load next field in base }
     i:=pos('.',s);
     if i=0 then
      i:=255;
     base:=Copy(s,1,i-1);
     delete(s,1,i);
     sym:=search_struct_member(tabstractrecorddef(st.defowner),base);
     if not assigned(sym) then
      begin
        GetRecordOffsetSize:=false;
        exit;
      end;
     st:=nil;
     case sym.typ of
       fieldvarsym :
         with Tfieldvarsym(sym) do
           begin
             if not tabstractrecordsymtable(sym.owner).is_packed then
               inc(Offset,fieldoffset)
             else if tfieldvarsym(sym).fieldoffset mod 8 = 0 then
               inc(Offset,fieldoffset div 8)
             else
               Message(asmr_e_packed_element);
             size:=getsize;
             case vardef.typ of
               arraydef :
                 begin
                   { for arrays try to get the element size, take care of
                     multiple indexes }
                   harrdef:=tarraydef(vardef);
                   while assigned(harrdef.elementdef) and
                         (harrdef.elementdef.typ=arraydef) do
                    harrdef:=tarraydef(harrdef.elementdef);
                   if not is_packed_array(harrdef) then
                     size:=harrdef.elesize
                   else
                     begin
                       if (harrdef.elepackedbitsize mod 8) <> 0 then
                         Message(asmr_e_packed_element);
                       size := (harrdef.elepackedbitsize + 7) div 8;
                     end;
                 end;
               recorddef :
                 st:=trecorddef(vardef).symtable;
               objectdef :
                 st:=tobjectdef(vardef).symtable;
             end;
           end;
       procsym:
         begin
           st:=nil;
           if Tprocsym(sym).ProcdefList.Count>1 then
             Message(asmr_w_calling_overload_func);
           procdef:=tprocdef(tprocsym(sym).ProcdefList[0]);
           if (not needvmtofs) then
             begin
               mangledname:=procdef.mangledname;
             end
           else
             begin
               { can only get the vmtoffset of virtual methods }
               if not(po_virtualmethod in procdef.procoptions) or
                   is_objectpascal_helper(procdef.struct) then
                 Message1(asmr_e_no_vmtoffset_possible,FullTypeName(procdef,nil))
               else
                 begin
                   { size = sizeof(target_system_pointer) }
                   size:=sizeof(pint);
                   offset:=tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber)
                 end;
             end;
           { if something comes after the procsym, it's invalid assembler syntax }
           GetRecordOffsetSize:=(s='');
           exit;
         end;
     end;
   end;
   { Support Field.Type as typecasting }
   if (st=nil) and (s<>'') then
     begin
       asmsearchsym(s,sym,srsymtable);
       if assigned(sym) and (sym.typ=typesym) then
         begin
           size:=ttypesym(sym).typedef.size;
           s:=''
         end;
     end;
   GetRecordOffsetSize:=(s='');
end;


Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
var
  sym : tsym;
  srsymtable : TSymtable;
  hs  : string;
Begin
  hl:=nil;
  SearchLabel:=false;
{ Check for pascal labels, which are case insensetive }
  hs:=upper(s);
  asmsearchsym(hs,sym,srsymtable);
  if sym=nil then
   exit;
  case sym.typ of
    labelsym :
      begin
        if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
          begin
            Tlabelsym(sym).nonlocal:=true;
            if emit then
              exclude(current_procinfo.procdef.procoptions,po_inline);
          end;
        if not(assigned(tlabelsym(sym).asmblocklabel)) then
          if Tlabelsym(sym).nonlocal then
            current_asmdata.getglobaljumplabel(tlabelsym(sym).asmblocklabel)
          else
            current_asmdata.getjumplabel(tlabelsym(sym).asmblocklabel);
        hl:=tlabelsym(sym).asmblocklabel;
        if emit then
          tlabelsym(sym).defined:=true
        else
          tlabelsym(sym).used:=true;
        SearchLabel:=true;
      end;
  end;
end;


 {*************************************************************************}
 {                   Instruction Generation Utilities                      }
 {*************************************************************************}


   Procedure ConcatString(p : TAsmList;s:string);
  {*********************************************************************}
  { PROCEDURE ConcatString(s:string);                                   }
  {  Description: This routine adds the character chain pointed to in   }
  {  s to the instruction linked list.                                  }
  {*********************************************************************}
  Var
   pc: PChar;
  Begin
     getmem(pc,length(s)+1);
     p.concat(Tai_string.Create_pchar(strpcopy(pc,s),length(s)));
  end;

  Procedure ConcatPasString(p : TAsmList;s:string);
  {*********************************************************************}
  { PROCEDURE ConcatPasString(s:string);                                }
  {  Description: This routine adds the character chain pointed to in   }
  {  s to the instruction linked list, contrary to ConcatString it      }
  {  uses a pascal style string, so it conserves null characters.       }
  {*********************************************************************}
  Begin
     p.concat(Tai_string.Create(s));
  end;


Procedure ConcatConstant(p: TAsmList; value: aint; constsize:byte);
{*********************************************************************}
{ PROCEDURE ConcatConstant(value: aint; maxvalue: aint);        }
{  Description: This routine adds the value constant to the current   }
{  instruction linked list.                                           }
{   maxvalue -> indicates the size of the data to initialize:         }
{                  $ff -> create a byte node.                         }
{                  $ffff -> create a word node.                       }
{                  $ffffffff -> create a dword node.                  }
{*********************************************************************}
var
  rangelo,rangehi : int64;
Begin
  case constsize of
    1 :
      begin
        p.concat(Tai_const.Create_8bit(byte(value)));
        rangelo:=low(shortint);
        rangehi:=high(byte);
      end;
    2 :
      begin
        p.concat(Tai_const.Create_16bit(word(value)));
        rangelo:=low(smallint);
        rangehi:=high(word);
      end;
    4 :
      begin
        p.concat(Tai_const.Create_32bit(longint(value)));
        rangelo:=low(longint);
        rangehi:=high(cardinal);
      end;
    8 :
      begin
        p.concat(Tai_const.Create_64bit(int64(value)));
        rangelo:=0;
        rangehi:=0;
      end;
    else
      internalerror(200405011);
  end;
  { check for out of bounds }
  if (rangelo<>0) and
     ((value>rangehi) or (value<rangelo)) then
    Message(asmr_e_constant_out_of_bounds);
end;


  Procedure ConcatConstSymbol(p : TAsmList;const sym:string;symtyp:tasmsymtype;l:aint);
  begin
    p.concat(Tai_const.Createname(sym,l));
  end;


  Procedure ConcatRealConstant(p : TAsmList;value: bestreal; real_typ : tfloattype);
  {***********************************************************************}
  { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
  {  Description: This routine adds the value constant to the current     }
  {  instruction linked list.                                             }
  {   real_typ -> indicates the type of the real data to initialize:      }
  {                  s32real -> create a single node.                     }
  {                  s64real -> create a double node.                     }
  {                  s80real -> create an extended node.                  }
  {                  s64bit ->  create a  comp node.                      }
  {                  f32bit ->  create a  fixed node. (not used normally) }
  {***********************************************************************}
    Begin
       case real_typ of
          s32real : p.concat(Tai_real_32bit.Create(value));
          s64real :
{$ifdef ARM}
           if is_double_hilo_swapped then
             p.concat(Tai_real_64bit.Create_hiloswapped(value))
           else
{$endif ARM}
             p.concat(Tai_real_64bit.Create(value));
          s80real : p.concat(Tai_real_80bit.Create(value,s80floattype.size));
          sc80real : p.concat(Tai_real_80bit.Create(value,sc80floattype.size));
          s64comp : p.concat(Tai_comp_64bit.Create(trunc(value)));
       end;
    end;

   Procedure ConcatLabel(p: TAsmList;var l : tasmlabel);
  {*********************************************************************}
  { PROCEDURE ConcatLabel                                               }
  {  Description: This routine either emits a label or a labeled        }
  {  instruction to the linked list of instructions.                    }
  {*********************************************************************}
   begin
     p.concat(Tai_label.Create(l));
   end;

   procedure ConcatAlign(p:TAsmList;l:aint);
  {*********************************************************************}
  { PROCEDURE ConcatPublic                                              }
  {  Description: This routine emits an global   definition to the      }
  {  linked list of instructions.(used by AT&T styled asm)              }
  {*********************************************************************}
   begin
     p.concat(Tai_align.Create(l));
   end;

   procedure ConcatPublic(p:TAsmList;const s : string);
  {*********************************************************************}
  { PROCEDURE ConcatPublic                                              }
  {  Description: This routine emits an global   definition to the      }
  {  linked list of instructions.(used by AT&T styled asm)              }
  {*********************************************************************}
   begin
       p.concat(Tai_symbol.Createname_global(s,AT_LABEL,0));
   end;

   procedure ConcatLocal(p:TAsmList;const s : string);
  {*********************************************************************}
  { PROCEDURE ConcatLocal                                               }
  {  Description: This routine emits an local    definition to the      }
  {  linked list of instructions.                                       }
  {*********************************************************************}
   begin
       p.concat(Tai_symbol.Createname(s,AT_LABEL,0));
   end;


end.