1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459 |
- {
- $Id$
- Copyright (c) 1998 Carl Eric Codere
- 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;
- Interface
- Uses
- strings,
- cobjects,
- globtype,systems,verbose,globals,files,
- symconst,symtable,aasm,hcodegen
- {$ifdef i386}
- ,i386base,i386asm
- {$endif}
- {$ifdef m68k}
- ,m68k
- {$endif}
- ;
- Const
- RPNMax = 10; { I think you only need 4, but just to be safe }
- OpMax = 25;
- maxoperands = 3; { Maximum operands for assembler instructions }
- {---------------------------------------------------------------------
- Local Label Management
- ---------------------------------------------------------------------}
- Type
- { Each local label has this structure associated with it }
- PLocalLabel = ^TLocalLabel;
- TLocalLabel = object(TNamedIndexObject)
- Emitted : boolean;
- constructor Init(const n:string);
- function Getpasmlabel:pasmlabel;
- private
- lab : pasmlabel;
- end;
- PLocalLabelList = ^TLocalLabelList;
- TLocalLabelList = Object(TDictionary)
- procedure CheckEmitted;
- end;
- var
- LocalLabelList : PLocalLabelList;
- function CreateLocalLabel(const s: string; var hl: pasmlabel; emit:boolean):boolean;
- Function SearchLabel(const s: string; var hl: pasmlabel;emit:boolean): boolean;
- {---------------------------------------------------------------------
- Instruction management
- ---------------------------------------------------------------------}
- type
- TOprType=(OPR_NONE,OPR_CONSTANT,OPR_SYMBOL,OPR_REFERENCE,OPR_REGISTER);
- TOprRec = record
- case typ:TOprType of
- OPR_NONE : ();
- OPR_CONSTANT : (val:longint);
- OPR_SYMBOL : (symbol:PAsmSymbol;symofs:longint);
- OPR_REFERENCE : (ref:treference);
- OPR_REGISTER : (reg:tregister);
- end;
- POperand = ^TOperand;
- TOperand = object
- size : topsize;
- hasvar : boolean; { if the operand is loaded with a variable }
- opr : TOprRec;
- constructor init;
- destructor done;virtual;
- Procedure BuildOperand;virtual;
- Procedure SetSize(_size:longint);
- Function SetupResult:boolean;
- Function SetupSelf:boolean;
- Function SetupOldEBP:boolean;
- Function SetupVar(const hs:string): Boolean;
- Function SetupDirectVar(const hs:string): Boolean;
- Procedure InitRef;
- end;
- PInstruction = ^TInstruction;
- TInstruction = object
- opcode : tasmop;
- opsize : topsize;
- condition : tasmcond;
- ops : byte;
- operands : array[1..maxoperands] of POperand;
- constructor init;
- destructor done;virtual;
- Procedure InitOperands;virtual;
- Procedure BuildOpcode;virtual;
- procedure ConcatInstruction(p:PAasmoutput);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;
- String15 = String[15];
- {**********************************************************************}
- { 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 = Object
- public
- Constructor Init;
- Destructor Done;
- Function Evaluate(Expr: String): longint;
- Function Priority(_Operator: Char): Integer; virtual;
- private
- RPNStack : Array[1..RPNMax] of longint; { Stack For RPN calculator }
- RPNTop : Integer;
- OpStack : Array[1..OpMax] of TExprOperator; { Operator stack For conversion }
- OpTop : Integer;
- Procedure RPNPush(Num: Longint);
- Function RPNPop: Longint;
- Procedure RPNCalc(token: String15; prefix: boolean);
- Procedure OpPush(_Operator: char; prefix: boolean);
- { In reality returns TExprOperaotr }
- Procedure OpPop(var _Operator:TExprOperator);
- end;
- { Evaluate an expression string to a longint }
- Function CalculateExpression(const expression: string): longint;
- {---------------------------------------------------------------------}
- { String routines }
- {---------------------------------------------------------------------}
- Function ValDecimal(const S:String):longint;
- Function ValOctal(const S:String):longint;
- Function ValBinary(const S:String):longint;
- Function ValHexaDecimal(const S:String):longint;
- Function PadZero(Var s: String; n: byte): Boolean;
- Function EscapeToPascal(const s:string): string;
- {---------------------------------------------------------------------
- Symbol helper routines
- ---------------------------------------------------------------------}
- Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean;
- Function SearchIConstant(const s:string; var l:longint): boolean;
- {---------------------------------------------------------------------
- Instruction generation routines
- ---------------------------------------------------------------------}
- Procedure ConcatPasString(p : paasmoutput;s:string);
- Procedure ConcatDirect(p : paasmoutput;s:string);
- Procedure ConcatLabel(p: paasmoutput;var l : pasmlabel);
- Procedure ConcatConstant(p : paasmoutput;value: longint; maxvalue: longint);
- Procedure ConcatConstSymbol(p : paasmoutput;const sym:string;l:longint);
- Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype);
- Procedure ConcatString(p : paasmoutput;s:string);
- procedure ConcatAlign(p:paasmoutput;l:longint);
- Procedure ConcatPublic(p:paasmoutput;const s : string);
- Procedure ConcatLocal(p:paasmoutput;const s : string);
- Procedure ConcatGlobalBss(const s : string;size : longint);
- Procedure ConcatLocalBss(const s : string;size : longint);
- Implementation
- {*************************************************************************
- TExprParse
- *************************************************************************}
- Constructor TExprParse.Init;
- Begin
- end;
- Procedure TExprParse.RPNPush(Num : longint);
- { 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_ev_stack_overflow);
- end;
- Function TExprParse.RPNPop : longint;
- { 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_ev_stack_underflow);
- end;
- Procedure TExprParse.RPNCalc(Token : String15; prefix:boolean); { RPN Calculator }
- Var
- Temp : longint;
- 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
- RPNPush(RPNPop - RPNPop);
- end;
- '*' : RPNPush(RPNPop * RPNPop);
- '&' : RPNPush(RPNPop AND RPNPop);
- '|' : RPNPush(RPNPop OR RPNPop);
- '~' : RPNPush(NOT RPNPop);
- '<' : RPNPush(RPNPop SHL RPNPop);
- '>' : RPNPush(RPNPop SHR RPNPop);
- '%' :
- begin
- Temp:=RPNPop;
- if Temp <> 0 then
- RPNPush(RPNPop mod Temp)
- else
- Message(asmr_e_ev_zero_divide);
- end;
- '^' : RPNPush(RPNPop XOR RPNPop);
- '/' :
- begin
- Temp:=RPNPop;
- if Temp <> 0 then
- RPNPush(RPNPop div Temp)
- else
- Message(asmr_e_ev_zero_divide);
- end;
- end
- else
- begin
- { Convert String to number and add to stack }
- if token='-2147483648' then
- begin
- temp:=$80000000;
- localerror:=0;
- end
- else
- Val(Token, Temp, LocalError);
- if LocalError = 0 then
- RPNPush(Temp)
- else
- Message(asmr_e_ev_invalid_number);
- 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_ev_stack_overflow);
- 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_ev_stack_underflow);
- end;
- Function TExprParse.Priority(_Operator : Char) : Integer;
- { 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_ev_invalid_op);
- end;
- end;
- Function TExprParse.Evaluate(Expr : String):longint;
- Var
- I : Integer;
- Token : String15;
- 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_ev_invalid_op); { 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.Done;
- Begin
- end;
- Function CalculateExpression(const expression: string): longint;
- var
- expr: TExprParse;
- Begin
- expr.Init;
- CalculateExpression:=expr.Evaluate(expression);
- expr.Done;
- 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 : longint;
- 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):longint;
- { Converts a decimal string to longint }
- var
- vs,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):longint;
- { Converts an octal string to longint }
- var
- vs,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):longint;
- { Converts a binary string to longint }
- var
- vs,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):longint;
- { Converts a binary string to longint }
- var
- vs,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.init;
- begin
- size:=S_NO;
- hasvar:=false;
- FillChar(Opr,sizeof(Opr),0);
- end;
- destructor TOperand.done;
- begin
- end;
- Procedure TOperand.SetSize(_size:longint);
- begin
- if (size = S_NO) then
- Begin
- case _size of
- 1 : size:=S_B;
- 2 : size:=S_W{ could be S_IS};
- 4 : size:=S_L{ could be S_IL or S_FS};
- 8 : size:=S_IQ{ could be S_D or S_FL};
- extended_size : size:=S_FX;
- end;
- end;
- end;
- Function TOperand.SetupResult:boolean;
- Begin
- SetupResult:=false;
- { replace by correct offset. }
- if assigned(procinfo.retdef) and
- (procinfo.retdef<>pdef(voiddef)) then
- begin
- opr.ref.offset:=procinfo.retoffset;
- opr.ref.base:= procinfo.framepointer;
- { always assume that the result is valid. }
- procinfo.funcret_is_valid:=true;
- SetupResult:=true;
- end
- else
- Message(asmr_e_void_function);
- end;
- Function TOperand.SetupSelf:boolean;
- Begin
- SetupSelf:=false;
- if assigned(procinfo._class) then
- Begin
- opr.ref.offset:=procinfo.ESI_offset;
- opr.ref.base:=procinfo.framepointer;
- SetupSelf:=true;
- end
- else
- Message(asmr_e_cannot_use_SELF_outside_a_method);
- end;
- Function TOperand.SetupOldEBP:boolean;
- Begin
- SetupOldEBP:=false;
- if lexlevel>normal_function_level then
- Begin
- opr.typ:=OPR_REFERENCE;
- opr.ref.offset:=procinfo.framepointer_offset;
- opr.ref.base:=procinfo.framepointer;
- SetupOldEBP:=true;
- end
- else
- Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
- end;
- Function TOperand.SetupVar(const hs:string): Boolean;
- { 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 : psym;
- Begin
- SetupVar:=false;
- { are we in a routine ? }
- getsym(hs,false);
- sym:=srsym;
- if sym=nil then
- exit;
- case sym^.typ of
- varsym :
- begin
- { we always assume in asm statements that }
- { that the variable is valid. }
- pvarsym(sym)^.varstate:=vs_used;
- inc(pvarsym(sym)^.refs);
- case pvarsym(sym)^.owner^.symtabletype of
- unitsymtable,
- globalsymtable,
- staticsymtable :
- opr.ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname);
- parasymtable :
- begin
- opr.ref.base:=procinfo.framepointer;
- opr.ref.offset:=pvarsym(sym)^.address;
- opr.ref.offsetfixup:=aktprocsym^.definition^.parast^.address_fixup;
- opr.ref.options:=ref_parafixup;
- end;
- localsymtable :
- begin
- if (vo_is_external in pvarsym(sym)^.varoptions) then
- opr.ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname)
- else
- begin
- opr.ref.base:=procinfo.framepointer;
- opr.ref.offset:=-(pvarsym(sym)^.address);
- opr.ref.options:=ref_localfixup;
- opr.ref.offsetfixup:=aktprocsym^.definition^.localst^.address_fixup;
- end;
- end;
- end;
- case pvarsym(sym)^.definition^.deftype of
- orddef,
- enumdef,
- pointerdef,
- floatdef :
- SetSize(pvarsym(sym)^.getsize);
- arraydef :
- SetSize(parraydef(pvarsym(sym)^.definition)^.elesize)
- end;
- hasvar:=true;
- SetupVar:=true;
- Exit;
- end;
- typedconstsym :
- begin
- opr.ref.symbol:=newasmsymbol(ptypedconstsym(sym)^.mangledname);
- case ptypedconstsym(sym)^.definition^.deftype of
- orddef,
- enumdef,
- pointerdef,
- floatdef :
- SetSize(ptypedconstsym(sym)^.getsize);
- arraydef :
- SetSize(parraydef(ptypedconstsym(sym)^.definition)^.elesize)
- end;
- hasvar:=true;
- SetupVar:=true;
- Exit;
- end;
- constsym :
- begin
- if pconstsym(sym)^.consttype in [constint,constchar,constbool] then
- begin
- opr.typ:=OPR_CONSTANT;
- opr.val:=pconstsym(sym)^.value;
- hasvar:=true;
- SetupVar:=true;
- Exit;
- end;
- end;
- typesym :
- begin
- if ptypesym(sym)^.definition^.deftype in [recorddef,objectdef] then
- begin
- opr.typ:=OPR_CONSTANT;
- opr.val:=0;
- hasvar:=true;
- SetupVar:=TRUE;
- Exit;
- end;
- end;
- procsym :
- begin
- if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
- Message(asmr_w_calling_overload_func);
- opr.typ:=OPR_SYMBOL;
- opr.symbol:=newasmsymbol(pprocsym(sym)^.definition^.mangledname);
- 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;
- {$ifndef OLDDIRECTVAR}
- var
- p : pasmsymbol;
- begin
- SetupDirectVar:=false;
- p:=getasmsymbol(hs);
- if assigned(p) then
- begin
- opr.ref.symbol:=p;
- hasvar:=true;
- SetupDirectVar:=true;
- end;
- end;
- {$else}
- var
- p : pai_external;
- Begin
- SearchDirectVar:=false;
- { search in the list of internals }
- p:=search_assembler_symbol(internals,hs,EXT_ANY);
- if p=nil then
- p:=search_assembler_symbol(externals,hs,EXT_ANY);
- if p<>nil then
- begin
- instr.operands[operandnum].opr.ref.symbol:=p^.sym;
- case p^.exttyp of
- EXT_BYTE : instr.operands[operandnum].size:=S_B;
- EXT_WORD : instr.operands[operandnum].size:=S_W;
- EXT_NEAR,EXT_FAR,EXT_PROC,EXT_DWORD,EXT_CODEPTR,EXT_DATAPTR:
- instr.operands[operandnum].size:=S_L;
- EXT_QWORD : instr.operands[operandnum].size:=S_FL;
- EXT_TBYTE : instr.operands[operandnum].size:=S_FX;
- else
- { this is in the case where the instruction is LEA }
- { or something like that, in that case size is not }
- { important. }
- instr.operands[operandnum].size:=S_NO;
- end;
- instr.operands[operandnum].hasvar:=true;
- SearchDirectVar:=TRUE;
- Exit;
- end;
- end;
- {$endif}
- 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. }
- {*********************************************************************}
- Begin
- case opr.typ of
- OPR_REFERENCE:
- exit;
- OPR_NONE: ;
- else
- Message(asmr_e_invalid_operand_type);
- end;
- opr.typ := OPR_REFERENCE;
- reset_reference(opr.ref);
- end;
- procedure TOperand.BuildOperand;
- begin
- abstract;
- end;
- {****************************************************************************
- TInstruction
- ****************************************************************************}
- constructor TInstruction.init;
- Begin
- Opcode:=A_NONE;
- Opsize:=S_NO;
- Condition:=C_NONE;
- Ops:=0;
- InitOperands;
- end;
- destructor TInstruction.done;
- var
- i : longint;
- Begin
- for i:=1 to 3 do
- Dispose(Operands[i],Done);
- end;
- procedure TInstruction.InitOperands;
- var
- i : longint;
- begin
- for i:=1 to 3 do
- New(Operands[i],init);
- end;
- Procedure TInstruction.SwapOperands;
- Var
- p : POperand;
- 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;
- procedure TInstruction.ConcatInstruction(p:PAasmOutput);
- begin
- abstract;
- end;
- procedure TInstruction.BuildOpcode;
- begin
- abstract;
- end;
- {***************************************************************************
- TLocalLabel
- ***************************************************************************}
- constructor TLocalLabel.Init(const n:string);
- begin
- inherited InitName(n);
- lab:=nil;
- emitted:=false;
- end;
- function TLocalLabel.Getpasmlabel:pasmlabel;
- begin
- if not assigned(lab) then
- begin
- getlabel(lab);
- { this label is forced to be used so it's always written }
- inc(lab^.refs);
- end;
- Getpasmlabel:=lab;
- end;
- {***************************************************************************
- TLocalLabelList
- ***************************************************************************}
- procedure LocalLabelEmitted(p:PNamedIndexObject);{$ifndef FPC}far;{$endif}
- begin
- if not PLocalLabel(p)^.emitted then
- Message1(asmr_e_unknown_label_identifier,p^.name);
- end;
- procedure TLocalLabelList.CheckEmitted;
- begin
- ForEach({$ifndef TP}@{$endif}LocalLabelEmitted)
- end;
- function CreateLocalLabel(const s: string; var hl: pasmlabel; emit:boolean):boolean;
- var
- lab : PLocalLabel;
- Begin
- CreateLocalLabel:=true;
- { Check if it already is defined }
- lab:=PLocalLabel(LocalLabelList^.Search(s));
- if not assigned(lab) then
- begin
- new(lab,init(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^.Getpasmlabel;
- end;
- {****************************************************************************
- Symbol table helper routines
- ****************************************************************************}
- Function SearchIConstant(const s:string; var l:longint): 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
- sym: psym;
- Begin
- SearchIConstant:=false;
- { check for TRUE or FALSE reserved words first }
- if s = 'TRUE' then
- Begin
- SearchIConstant:=TRUE;
- l:=1;
- end
- else
- if s = 'FALSE' then
- Begin
- SearchIConstant:=TRUE;
- l:=0;
- end
- else
- if assigned(aktprocsym) then
- Begin
- if assigned(aktprocsym^.definition) then
- Begin
- { Check the local constants }
- if assigned(aktprocsym^.definition^.localst) and
- (lexlevel >= normal_function_level) then
- sym:=aktprocsym^.definition^.localst^.search(s)
- else
- sym:=nil;
- if assigned(sym) then
- Begin
- if (sym^.typ = constsym) and
- (pconstsym(sym)^.consttype in [constord,constint,constchar,constbool]) then
- Begin
- l:=pconstsym(sym)^.value;
- SearchIConstant:=TRUE;
- exit;
- end;
- end;
- end;
- end;
- { Check the global constants }
- getsym(s,false);
- if srsym <> nil then
- Begin
- case srsym^.typ of
- constsym :
- begin
- if (pconstsym(srsym)^.consttype in [constord,constint,constchar,constbool]) then
- Begin
- l:=pconstsym(srsym)^.value;
- SearchIConstant:=TRUE;
- exit;
- end;
- end;
- end;
- end;
- end;
- Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):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 : psymtable;
- sym : psym;
- 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);
- getsym(base,false);
- sym:=srsym;
- st:=nil;
- { we can start with a var,type,typedconst }
- case sym^.typ of
- varsym :
- begin
- case pvarsym(sym)^.definition^.deftype of
- recorddef :
- st:=precorddef(pvarsym(sym)^.definition)^.symtable;
- objectdef :
- st:=pobjectdef(pvarsym(sym)^.definition)^.symtable;
- end;
- end;
- typesym :
- begin
- case ptypesym(sym)^.definition^.deftype of
- recorddef :
- st:=precorddef(ptypesym(sym)^.definition)^.symtable;
- objectdef :
- st:=pobjectdef(ptypesym(sym)^.definition)^.symtable;
- end;
- end;
- typedconstsym :
- begin
- case pvarsym(sym)^.definition^.deftype of
- recorddef :
- st:=precorddef(ptypedconstsym(sym)^.definition)^.symtable;
- objectdef :
- st:=pobjectdef(ptypedconstsym(sym)^.definition)^.symtable;
- end;
- end;
- 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:=st^.search(base);
- st:=nil;
- case sym^.typ of
- varsym :
- begin
- inc(Offset,pvarsym(sym)^.address);
- Size:=PVarsym(sym)^.getsize;
- case pvarsym(sym)^.definition^.deftype of
- recorddef :
- st:=precorddef(pvarsym(sym)^.definition)^.symtable;
- objectdef :
- st:=pobjectdef(pvarsym(sym)^.definition)^.symtable;
- end;
- end;
- end;
- end;
- GetRecordOffsetSize:=(s='');
- end;
- Function SearchLabel(const s: string; var hl: pasmlabel;emit:boolean): boolean;
- var
- sym : psym;
- hs : string;
- Begin
- hl:=nil;
- SearchLabel:=false;
- { Check for pascal labels, which are case insensetive }
- hs:=upper(s);
- getsym(hs,false);
- sym:=srsym;
- if sym=nil then
- exit;
- case sym^.typ of
- labelsym :
- begin
- hl:=plabelsym(sym)^.lab;
- if emit then
- plabelsym(sym)^.defined:=true;
- SearchLabel:=true;
- exit;
- end;
- end;
- end;
- {*************************************************************************}
- { Instruction Generation Utilities }
- {*************************************************************************}
- Procedure ConcatString(p : paasmoutput;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(new(pai_string,init_length_pchar(strpcopy(pc,s),length(s))));
- end;
- Procedure ConcatPasString(p : paasmoutput;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(new(pai_string,init(s)));
- end;
- Procedure ConcatDirect(p : paasmoutput;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(new(pai_direct,init(strpcopy(pc,s))));
- end;
- Procedure ConcatConstant(p: paasmoutput; value: longint; maxvalue: longint);
- {*********************************************************************}
- { PROCEDURE ConcatConstant(value: longint; maxvalue: longint); }
- { 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. }
- {*********************************************************************}
- Begin
- if (maxvalue <> $ffffffff) and (value > maxvalue) then
- Begin
- Message(asmr_e_constant_out_of_bounds);
- { assuming a value of maxvalue }
- value:=maxvalue;
- end;
- if maxvalue = $ff then
- p^.concat(new(pai_const,init_8bit(byte(value))))
- else
- if maxvalue = $ffff then
- p^.concat(new(pai_const,init_16bit(word(value))))
- else
- if maxvalue = $ffffffff then
- p^.concat(new(pai_const,init_32bit(longint(value))));
- end;
- Procedure ConcatConstSymbol(p : paasmoutput;const sym:string;l:longint);
- begin
- p^.concat(new(pai_const_symbol,initname_offset(sym,l)));
- end;
- Procedure ConcatRealConstant(p : paasmoutput;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(new(pai_real_32bit,init(value)));
- s64real : p^.concat(new(pai_real_64bit,init(value)));
- s80real : p^.concat(new(pai_real_80bit,init(value)));
- s64comp : p^.concat(new(pai_comp_64bit,init(value)));
- f32bit : p^.concat(new(pai_const,init_32bit(trunc(value*$10000))));
- end;
- end;
- Procedure ConcatLabel(p: paasmoutput;var l : pasmlabel);
- {*********************************************************************}
- { PROCEDURE ConcatLabel }
- { Description: This routine either emits a label or a labeled }
- { instruction to the linked list of instructions. }
- {*********************************************************************}
- begin
- p^.concat(new(pai_label,init(l)));
- end;
- procedure ConcatAlign(p:paasmoutput;l:longint);
- {*********************************************************************}
- { PROCEDURE ConcatPublic }
- { Description: This routine emits an global definition to the }
- { linked list of instructions.(used by AT&T styled asm) }
- {*********************************************************************}
- begin
- p^.concat(new(pai_align,init(l)));
- end;
- procedure ConcatPublic(p:paasmoutput;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(new(pai_symbol,initname_global(s,0)));
- end;
- procedure ConcatLocal(p:paasmoutput;const s : string);
- {*********************************************************************}
- { PROCEDURE ConcatLocal }
- { Description: This routine emits an local definition to the }
- { linked list of instructions. }
- {*********************************************************************}
- begin
- p^.concat(new(pai_symbol,initname(s,0)));
- end;
- Procedure ConcatGlobalBss(const s : string;size : longint);
- {*********************************************************************}
- { PROCEDURE ConcatGlobalBss }
- { Description: This routine emits an global datablock to the }
- { linked list of instructions. }
- {*********************************************************************}
- begin
- bsssegment^.concat(new(pai_datablock,init_global(s,size)));
- end;
- Procedure ConcatLocalBss(const s : string;size : longint);
- {*********************************************************************}
- { PROCEDURE ConcatLocalBss }
- { Description: This routine emits a local datablcok to the }
- { linked list of instructions. }
- {*********************************************************************}
- begin
- bsssegment^.concat(new(pai_datablock,init(s,size)));
- end;
- end.
- {
- $Log$
- Revision 1.21 1999-08-03 22:03:12 peter
- * moved bitmask constants to sets
- * some other type/const renamings
- Revision 1.20 1999/07/29 20:54:06 peter
- * write .size also
- Revision 1.19 1999/06/02 22:44:17 pierre
- * previous wrong log corrected
- Revision 1.18 1999/06/02 22:25:47 pierre
- * changed $ifdef FPC @ into $ifndef TP
- Revision 1.17 1999/05/27 19:45:01 peter
- * removed oldasm
- * plabel -> pasmlabel
- * -a switches to source writing automaticly
- * assembler readers OOPed
- * asmsymbol automaticly external
- * jumptables and other label fixes for asm readers
- Revision 1.16 1999/05/21 13:55:18 peter
- * NEWLAB for label as symbol
- Revision 1.15 1999/05/12 00:17:11 peter
- * fixed error which was shown for all 32bit consts
- Revision 1.14 1999/05/11 16:27:23 peter
- * support for pointerdef
- Revision 1.13 1999/05/06 09:05:27 peter
- * generic write_float and str_float
- * fixed constant float conversions
- Revision 1.12 1999/05/05 22:22:04 peter
- * updated messages
- Revision 1.11 1999/05/02 22:41:57 peter
- * moved section names to systems
- * fixed nasm,intel writer
- Revision 1.10 1999/05/01 13:24:41 peter
- * merged nasm compiler
- * old asm moved to oldasm/
- Revision 1.8 1999/04/26 23:26:19 peter
- * redesigned record offset parsing to support nested records
- * normal compiler uses the redesigned SetupVar()
- Revision 1.7 1999/04/14 09:07:48 peter
- * asm reader improvements
- Revision 1.6 1999/03/31 13:55:34 peter
- * assembler inlining working for ag386bin
- Revision 1.5 1999/03/26 00:01:17 peter
- * first things for optimizer (compiles but cycle crashes)
- Revision 1.4 1999/03/25 16:55:36 peter
- + unitpath,librarypath,includepath,objectpath directives
- Revision 1.3 1999/03/06 17:24:28 peter
- * rewritten intel parser a lot, especially reference reading
- * size checking added for asm parsers
- Revision 1.2 1999/03/02 02:56:33 peter
- + stabs support for binary writers
- * more fixes and missing updates from the previous commit :(
- Revision 1.1 1999/03/01 15:46:26 peter
- * ag386bin finally make cycles correct
- * prefixes are now also normal opcodes
- }
|