fpc/compiler/rautils.pas

{
    $Id$
    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,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(TNamedIndexItem)
    Emitted : boolean;
    constructor Create(const n:string);
    function  Gettasmlabel:tasmlabel;
  private
    lab : tasmlabel;
  end;

  TLocalLabelList = class(TDictionary)
    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);

  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:boolean);
      OPR_REGISTER  : (reg:tregister);
{$ifdef m68k}
      OPR_REGLIST   : (regset : tcpuregisterset);
{$endif m68k}
{$ifdef powerpc}
      OPR_COND      : (cond : tasmcond);
{$endif powerpc}
{$ifdef arm}
      OPR_REGSET    : (regset : tcpuregisterset);
{$endif arm}
  end;

  TOperand = class
    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  SetupDirectVar(const hs:string): Boolean;
    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;
    Procedure BuildOpcode;virtual;abstract;
    { 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 }
    function ConcatInstruction(p:TAAsmoutput) : tai;virtual;
    Procedure Swapoperands;
  end;

  tstr2opentry = class(Tnamedindexitem)
    op: TAsmOp;
  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 ValDecimal(const S:String):aint;
Function ValOctal(const S:String):aint;
Function ValBinary(const S:String):aint;
Function ValHexaDecimal(const S:String):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):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 : TAAsmoutput;s:string);
  Procedure ConcatDirect(p : TAAsmoutput;s:string);
  Procedure ConcatLabel(p: TAAsmoutput;var l : tasmlabel);
  Procedure ConcatConstant(p : TAAsmoutput;value: aint; constsize:byte);
  Procedure ConcatConstSymbol(p : TAAsmoutput;const sym:string;l:aint);
  Procedure ConcatRealConstant(p : TAAsmoutput;value: bestreal; real_typ : tfloattype);
  Procedure ConcatString(p : TAAsmoutput;s:string);
  procedure ConcatAlign(p:TAAsmoutput;l:aint);
  Procedure ConcatPublic(p:TAAsmoutput;const s : string);
  Procedure ConcatLocal(p:TAAsmoutput;const s : string);
  Procedure ConcatGlobalBss(const s : string;size : aint);
  Procedure ConcatLocalBss(const s : string;size : aint);


Implementation

uses
  strings,
  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;
    '+', '-' :
      Priority:=1;
    '*', '/','%','<','>' :
      Priority:=2;
    '|','&','^','~' :
      Priority:=0;
    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 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(ValOctal(temp));
           end;
         'x':
           Begin
             temp:=s[i+1];
             temp:=temp+s[i+2];
             inc(i,2);
             c:=chr(ValHexaDecimal(temp));
           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 ValDecimal(const S:String):aint;
{ Converts a decimal string to aint }
var
  vs : aint;
  c : longint;
Begin
  vs:=0;
  for c:=1 to length(s) do
   begin
     vs:=vs*10;
     if s[c] in ['0'..'9'] then
      inc(vs,ord(s[c])-ord('0'))
     else
      begin
        Message1(asmr_e_error_converting_decimal,s);
        ValDecimal:=0;
        exit;
      end;
   end;
  ValDecimal:=vs;
end;


Function ValOctal(const S:String):aint;
{ Converts an octal string to aint }
var
  vs : aint;
  c : longint;
Begin
  vs:=0;
  for c:=1 to length(s) do
   begin
     vs:=vs shl 3;
     if s[c] in ['0'..'7'] then
      inc(vs,ord(s[c])-ord('0'))
     else
      begin
        Message1(asmr_e_error_converting_octal,s);
        ValOctal:=0;
        exit;
      end;
   end;
  ValOctal:=vs;
end;


Function ValBinary(const S:String):aint;
{ Converts a binary string to aint }
var
  vs : aint;
  c : longint;
Begin
  vs:=0;
  for c:=1 to length(s) do
   begin
     vs:=vs shl 1;
     if s[c] in ['0'..'1'] then
      inc(vs,ord(s[c])-ord('0'))
     else
      begin
        Message1(asmr_e_error_converting_binary,s);
        ValBinary:=0;
        exit;
      end;
   end;
  ValBinary:=vs;
end;


Function ValHexadecimal(const S:String):aint;
{ Converts a binary string to aint }
var
  vs : aint;
  c : longint;
Begin
  vs:=0;
  for c:=1 to length(s) do
   begin
     vs:=vs shl 4;
     case s[c] of
       '0'..'9' :
         inc(vs,ord(s[c])-ord('0'));
       'A'..'F' :
         inc(vs,ord(s[c])-ord('A')+10);
       'a'..'f' :
         inc(vs,ord(s[c])-ord('a')+10);
       else
         begin
           Message1(asmr_e_error_converting_hexadecimal,s);
           ValHexadecimal:=0;
           exit;
         end;
     end;
   end;
  ValHexadecimal:=vs;
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(rettype.def)) then
      begin
        if (m_tp7 in aktmodeswitches) and
          (not paramanager.ret_in_param(rettype.def,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_procinfo.procdef._class) 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;
  begin
    result:=false;
    sym:=tsym(st.symindex.first);
    while assigned(sym) do
      begin
        if sym.typ=localvarsym then
          begin
            result:=true;
            exit;
          end;
        sym:=tsym(sym.indexnext);
      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 : psymlistitem;
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
        setconst(tfieldvarsym(sym).fieldoffset);
        hasvar:=true;
        SetupVar:=true;
      end;
    globalvarsym,
    localvarsym,
    paravarsym :
      begin
        { we always assume in asm statements that     }
        { that the variable is valid.                 }
        tabstractvarsym(sym).varstate:=vs_used;
        inc(tabstractvarsym(sym).refs);
        { variable can't be placed in a register }
        tabstractvarsym(sym).varregable:=vr_none;
        case sym.owner.symtabletype of
          globalsymtable,
          staticsymtable :
            begin
              initref;
              opr.ref.symbol:=objectlibrary.newasmsymbol(tglobalvarsym(sym).mangledname,AB_EXTERNAL,AT_DATA);
            end;
          parasymtable,
          localsymtable :
            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
                 (current_procinfo.procdef.proccalloption<>pocall_inline) 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).vartype.def,current_procinfo.procdef.proccalloption) then
                SetSize(sizeof(aint),false);
            end;
        end;
        case tabstractvarsym(sym).vartype.def.deftype 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).vartype.def);
              while assigned(harrdef.elementtype.def) and
                    (harrdef.elementtype.def.deftype=arraydef) do
               harrdef:=tarraydef(harrdef.elementtype.def);
              SetSize(harrdef.elesize,false);
            end;
        end;
        hasvar:=true;
        SetupVar:=true;
        Exit;
      end;
    typedconstsym :
      begin
        initref;
        opr.ref.symbol:=objectlibrary.newasmsymbol(ttypedconstsym(sym).mangledname,AB_EXTERNAL,AT_DATA);
        case ttypedconstsym(sym).typedconsttype.def.deftype of
          orddef,
          enumdef,
          pointerdef,
          floatdef :
            SetSize(ttypedconstsym(sym).getsize,false);
          arraydef :
            begin
              { for arrays try to get the element size, take care of
                multiple indexes }
              harrdef:=tarraydef(ttypedconstsym(sym).typedconsttype.def);
              while assigned(harrdef.elementtype.def) and
                    (harrdef.elementtype.def.deftype=arraydef) do
               harrdef:=tarraydef(harrdef.elementtype.def);
              SetSize(harrdef.elesize,false);
            end;
        end;
        hasvar:=true;
        SetupVar:=true;
        Exit;
      end;
    constsym :
      begin
        if tconstsym(sym).consttyp=constord then
         begin
           setconst(tconstsym(sym).value.valueord);
           SetupVar:=true;
           Exit;
         end;
      end;
    typesym :
      begin
        if ttypesym(sym).restype.def.deftype 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).procdef_count>1 then
          Message(asmr_w_calling_overload_func);
        l:=opr.ref.offset;
        opr.typ:=OPR_SYMBOL;
        opr.symbol:=objectlibrary.newasmsymbol(tprocsym(sym).first_procdef.mangledname,AB_EXTERNAL,AT_FUNCTION);
        opr.symofs:=l;
        hasvar:=true;
        SetupVar:=TRUE;
        Exit;
      end;
    else
      begin
        Message(asmr_e_unsupported_symbol_type);
        exit;
      end;
  end;
end;


{ looks for internal names of variables and routines }
Function TOperand.SetupDirectVar(const hs:string): Boolean;
var
  p : tasmsymbol;
begin
  SetupDirectVar:=false;
  p:=objectlibrary.getasmsymbol(hs);
  if assigned(p) then
   begin
     InitRef;
     opr.ref.symbol:=p;
     hasvar:=true;
     SetupDirectVar:=true;
   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;
  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;
    else
      begin
        Message(asmr_e_invalid_operand_type);
        { Recover }
        opr.typ:=OPR_REFERENCE;
        Fillchar(opr.ref,sizeof(treference),0);
      end;
  end;
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:TAAsmoutput) : tai;
    var
      ai   : taicpu;
      i : longint;
    begin
      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);
              OPR_REFERENCE:
                ai.loadref(i-1,ref);
{$ifdef ARM}
              OPR_REGSET:
                ai.loadregset(i-1,regset);
{$endif ARM}
            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(const n:string);
begin
  inherited CreateName(n);
  lab:=nil;
  emitted:=false;
end;


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


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

procedure LocalLabelEmitted(p:tnamedindexitem;arg:pointer);
begin
  if not TLocalLabel(p).emitted  then
   Message1(asmr_e_unknown_label_identifier,p.name);
end;

procedure TLocalLabelList.CheckEmitted;
begin
  ForEach_Static(@LocalLabelEmitted,nil)
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.Search(s));
  if not assigned(lab) then
   begin
     lab:=TLocalLabel.Create(s);
     LocalLabellist.Insert(lab);
   end;
{ 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.unitid=0) then
         srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,Copy(s,i+1,255))
        else
         srsym:=nil;
      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).restype.def.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).restype.def.deftype 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;
              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):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;
Begin
  GetRecordOffsetSize:=FALSE;
  Offset:=0;
  Size:=0;
  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_procinfo.procdef._class.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
         globalvarsym,
         localvarsym,
         paravarsym :
           st:=Tabstractvarsym(sym).vartype.def.getsymtable(gs_record);
         typesym :
           st:=Ttypesym(sym).restype.def.getsymtable(gs_record);
         typedconstsym :
           st:=Ttypedconstsym(sym).typedconsttype.def.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);
     if st.symtabletype=objectsymtable then
       sym:=search_class_member(tobjectdef(st.defowner),base)
     else
       sym:=tsym(st.search(base));
     if not assigned(sym) then
      begin
        GetRecordOffsetSize:=false;
        exit;
      end;
     st:=nil;
     case sym.typ of
       fieldvarsym :
         with Tfieldvarsym(sym) do
           begin
             inc(Offset,fieldoffset);
             size:=getsize;
             with vartype do
               case def.deftype of
                 arraydef :
                   begin
                     { for arrays try to get the element size, take care of
                       multiple indexes }
                     harrdef:=tarraydef(def);
                     while assigned(harrdef.elementtype.def) and
                           (harrdef.elementtype.def.deftype=arraydef) do
                      harrdef:=tarraydef(harrdef.elementtype.def);
                     size:=harrdef.elesize;
                   end;
                 recorddef :
                   st:=trecorddef(def).symtable;
                 objectdef :
                   st:=tobjectdef(def).symtable;
               end;
           end;
     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
        hl:=tlabelsym(sym).lab;
        if emit then
         tlabelsym(sym).defined:=true
        else
         tlabelsym(sym).used:=true;
        SearchLabel:=true;
      end;
  end;
end;


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


   Procedure ConcatString(p : TAAsmoutput;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_length_pchar(strpcopy(pc,s),length(s)));
  end;

  Procedure ConcatPasString(p : TAAsmoutput;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 ConcatDirect(p : TAAsmoutput;s:string);
  {*********************************************************************}
  { PROCEDURE ConcatDirect(s:string)                                    }
  {  Description: This routine output the string directly to the asm    }
  {  output, it is only sed when writing special labels in AT&T mode,   }
  {  and should not be used without due consideration, since it may     }
  {  cause problems.                                                    }
  {*********************************************************************}
  Var
   pc: PChar;
  Begin
     getmem(pc,length(s)+1);
     p.concat(Tai_direct.Create(strpcopy(pc,s)));
  end;




Procedure ConcatConstant(p: TAAsmoutput; 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 : TAAsmoutput;const sym:string;l:aint);
  begin
    p.concat(Tai_const.Createname(sym,AT_DATA,l));
  end;


  Procedure ConcatRealConstant(p : TAAsmoutput;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 aktfputype in [fpu_fpa,fpu_fpa10,fpu_fpa11] 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));
          s64comp : p.concat(Tai_comp_64bit.Create(trunc(value)));
       end;
    end;

   Procedure ConcatLabel(p: TAAsmoutput;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:TAAsmoutput;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:TAAsmoutput;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_FUNCTION,0));
   end;

   procedure ConcatLocal(p:TAAsmoutput;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_FUNCTION,0));
   end;

  Procedure ConcatGlobalBss(const s : string;size : aint);
  {*********************************************************************}
  { PROCEDURE ConcatGlobalBss                                           }
  {  Description: This routine emits an global  datablock   to the      }
  {  linked list of instructions.                                       }
  {*********************************************************************}
   begin
       bssSegment.concat(Tai_datablock.Create_global(s,size));
   end;

  Procedure ConcatLocalBss(const s : string;size : aint);
  {*********************************************************************}
  { PROCEDURE ConcatLocalBss                                            }
  {  Description: This routine emits a local datablcok      to the      }
  {  linked list of instructions.                                       }
  {*********************************************************************}
   begin
       bssSegment.concat(Tai_datablock.Create(s,size));
   end;

end.
{
  $Log$
  Revision 1.94  2004-11-08 22:09:59  peter
    * tvarsym splitted

  Revision 1.93  2004/10/31 21:45:03  peter
    * generic tlocation
    * move tlocation to cgutils

  Revision 1.92  2004/10/24 11:44:28  peter
    * small regvar fixes
    * loadref parameter removed from concatcopy,incrrefcount,etc

  Revision 1.91  2004/10/15 09:14:17  mazen
  - remove $IFDEF DELPHI and related code
  - remove $IFDEF FPCPROCVAR and related code

  Revision 1.90  2004/10/08 17:09:43  peter
    * tvarsym.varregable added, split vo_regable from varoptions

  Revision 1.89  2004/09/27 15:14:34  peter
    * reference local varsyms can't be regvar

  Revision 1.88  2004/06/20 08:55:30  florian
    * logs truncated

  Revision 1.87  2004/06/16 20:07:09  florian
    * dwarf branch merged

  Revision 1.86  2004/05/06 20:30:51  florian
    * m68k compiler compilation fixed

  Revision 1.85.2.7  2004/05/25 21:38:53  peter
    * assembler reader/writer updates

  Revision 1.85.2.6  2004/05/18 20:24:03  florian
    * fixed crash with unknown symbols

  Revision 1.85.2.5  2004/05/02 00:13:16  peter
    * remove limit of 15 digits

}