paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 02:49:37 +02:00
Code Issues Packages Projects Releases Wiki Activity
7b8f31d56a
fpc/compiler/ratti386.pas
pierre 9b14f1f183 * several bugfixes 
ADD ADC and AND are also sign extended
    nasm output OK (program still crashes at end
    and creates wrong assembler files !!)
    procsym types sym in tdef removed !!
1998-04-08 16:58:01 +00:00

3811 lines
149 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1997-98 by Carl Eric Codere
Does the parsing for the AT&T styled inline assembler.
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 Ratti386;
{**********************************************************************}
{ WARNING }
{**********************************************************************}
{ Any modification in the order or removal of terms in the tables }
{ in i386.pas and intasmi3.pas will BREAK the code in this unit, }
{ unless the appropriate changes are made to this unit. Addition }
{ of terms though, will not change the code herein. }
{**********************************************************************}
{--------------------------------------------------------------------}
{ LEFT TO DO: }
{--------------------------------------------------------------------}
{ o Handle record offsets }
{ o Add support imul,shld and shrd. }
{ o Add support for nor operators. }
{ o Bugfix of ao_imm8s for IMUL. (Currently the 3 operand imul will }
{ be considered as invalid because I use ao_imm8 and the table }
{ uses ao_imm8s). }
{ o In ConcatOpCode add more checking regarding suffixes and }
{ destination registers. (started but unfinished). }
{--------------------------------------------------------------------}
Interface
uses
i386,tree;
function assemble: ptree;
const
{ this variable is TRUE if the lookup tables have already been setup }
{ for fast access. On the first call to assemble the tables are setup }
{ and stay set up. }
_asmsorted: boolean = FALSE;
firstreg = R_EAX;
lastreg = R_ST7;
{ Hack to support all opcodes in the i386 table }
{ only tokens up to and including lastop_in_table }
{ are checked for validity, otherwise... }
lastop_in_table = A_POPFD;
type
tiasmops = array[firstop..lastop] of string[7];
piasmops = ^tiasmops;
var
{ sorted tables of opcodes }
iasmops: piasmops;
{ uppercased tables of registers }
iasmregs: array[firstreg..lastreg] of string[6];
Implementation
Uses
aasm,globals,AsmUtils,strings,hcodegen,scanner,
cobjects,verbose,symtable,types;
type
tinteltoken = (
AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_HEXNUM,AS_OCTALNUM,
AS_BINNUM,AS_REALNUM,AS_COMMA,AS_LPAREN,
AS_RPAREN,AS_COLON,AS_DOT,AS_PLUS,AS_MINUS,AS_STAR,AS_INTNUM,
AS_SEPARATOR,AS_ID,AS_REGISTER,AS_OPCODE,AS_SLASH,AS_DOLLAR,
{------------------ Assembler directives --------------------}
AS_DB,AS_DW,AS_DD,AS_DQ,AS_GLOBAL,AS_ALIGN,AS_ASCII,
AS_ASCIIZ,AS_LCOMM,AS_COMM,AS_SINGLE,AS_DOUBLE,AS_EXTENDED,
AS_DATA,AS_TEXT,AS_END,
{------------------ Assembler Operators --------------------}
AS_MOD,AS_SHL,AS_SHR,AS_NOT,AS_AND,AS_OR,AS_XOR,AS_NOR);
tasmkeyword = string[8];
const
{ These tokens should be modified accordingly to the modifications }
{ in the different enumerations. }
firstdirective = AS_DB;
lastdirective = AS_END;
firstsreg = R_CS;
lastsreg = R_SS;
_count_asmdirectives = longint(lastdirective)-longint(firstdirective);
_count_asmprefixes = 5;
_count_asmspecialops = 25;
_count_asmoverrides = 3;
_asmdirectives : array[0.._count_asmdirectives] of tasmkeyword =
('.byte','.word','.long','.quad','.globl','.align','.ascii',
'.asciz','.lcomm','.comm','.single','.double','.tfloat',
'.data','.text','END');
{------------------ Missing opcodes from std list ----------------}
_asmprefixes: array[0.._count_asmprefixes] of tasmkeyword = (
'REPNE','REPE','REP','REPZ','REPNZ','LOCK');
_prefixtokens: array[0.._count_asmprefixes] of tasmop = (
A_REPNE,A_REPE,A_REP,A_REPE,A_REPNE,A_LOCK);
_specialops: array[0.._count_asmspecialops] of tasmkeyword = (
'CMPSB','CMPSW','CMPSL','INSB','INSW','INSL','OUTSB','OUTSW','OUTSL',
'SCASB','SCASW','SCASL','STOSB','STOSW','STOSL','MOVSB','MOVSW','MOVSL',
'LODSB','LODSW','LODSL','LOCK','SEGCS','SEGDS','SEGES','SEGSS');
_specialopstokens: array[0.._count_asmspecialops] of tasmop = (
A_CMPS,A_CMPS,A_CMPS,A_INS,A_INS,A_INS,A_OUTS,A_OUTS,A_OUTS,
A_SCAS,A_SCAS,A_SCAS,A_STOS,A_STOS,A_STOS,A_MOVS,A_MOVS,A_MOVS,
A_LODS,A_LODS,A_LODS,A_LOCK,A_NONE,A_NONE,A_NONE,A_NONE);
{------------------------------------------------------------------}
{ register type definition table for easier searching }
_regtypes:array[firstreg..lastreg] of longint =
(ao_reg32,ao_reg32,ao_reg32,ao_reg32,ao_reg32,ao_reg32,ao_reg32,ao_reg32,
ao_reg16,ao_reg16,ao_reg16,ao_reg16,ao_reg16,ao_reg16,ao_reg16,ao_reg16,
ao_reg8,ao_reg8,ao_reg8,ao_reg8,ao_reg8,ao_reg8,ao_reg8,ao_reg8,
ao_none,ao_sreg2,ao_sreg2,ao_sreg2,ao_sreg3,ao_sreg3,ao_sreg2,
ao_floatacc,ao_floatacc,ao_floatreg,ao_floatreg,ao_floatreg,ao_floatreg,
ao_floatreg,ao_floatreg,ao_floatreg);
_regsizes: array[firstreg..lastreg] of topsize =
(S_L,S_L,S_L,S_L,S_L,S_L,S_L,S_L,
S_W,S_W,S_W,S_W,S_W,S_W,S_W,S_W,
S_B,S_B,S_B,S_B,S_B,S_B,S_B,S_B,
{ segment register }
S_W,S_W,S_W,S_W,S_W,S_W,S_W,
{ can also be S_S or S_T - must be checked at run-time }
S_Q,S_Q,S_Q,S_Q,S_Q,S_Q,S_Q,S_Q,S_Q);
_constsizes: array[S_NO..S_S] of longint =
(0,ao_imm8,ao_imm16,ao_imm32,0,0,0,0,ao_imm32);
{ converts from AT&T style to non-specific style... }
{'fildq','filds',
'fildl','fldl','fldt','fistq','fists','fistl','fstl','fsts',
'fstps','fistpl','fstpl','fistps','fistpq','fstpt','fcomps',
'ficompl','fcompl','ficomps','fcoms','ficoml','fcoml','ficoms',
'fiaddl','faddl','fiadds','fisubl','fsubl','fisubs','fsubs',
'fsubr','fsubrs','fisubrl','fsubrl','fisubrs','fmuls','fimull',
'fmull','fimuls','fdivs','fidivl','fdivl','fidivs','fdivrs',
'fidivrl','fdivrl','fidivrs','repe','repne','fadds','popfl', }
_fpusizes:array[A_FILDQ..A_FIDIVRS] of topsize = (
S_Q,S_S,S_L,S_L,S_X,S_Q,S_S,S_L,S_L,S_S,
S_S,S_L,S_L,S_S,S_Q,S_X,
S_S,S_L,S_L,S_S,
S_S,S_L,S_L,S_S,S_L,S_L,S_S,
S_L,S_L,S_S,S_S,S_NO,S_S,S_L,
S_L,S_S,S_S,S_L,S_L,S_S,S_S,S_L,
S_L,S_S,S_S,S_L,S_L,S_S);
_fpuopcodes:array[A_FILDQ..A_FIDIVRS] of tasmop = (
A_FILD,A_FILD,A_FILD,A_FLD,A_FLD,A_FIST,A_FIST,A_FIST,A_FST,A_FST,
A_FSTP,A_FISTP,A_FSTP,A_FISTP,A_FISTP,A_FSTP,
A_FCOMP,A_FICOMP,A_FCOMP,A_FICOMP,
A_FCOM,A_FICOM,A_FCOM,A_FICOM,A_FIADD,A_FADD,A_FIADD,
A_FISUB,A_FSUB,A_FISUB,A_FSUB,A_FSUB,A_FSUBR,A_FISUBR,
A_FSUBR,A_FISUBR,A_FMUL,A_FIMUL,A_FMUL,A_FIMUL,A_FDIV,A_FIDIV,
A_FDIV,A_FIDIV,A_FDIVR,A_FIDIVR,A_FDIVR,A_FIDIVR);
const
newline = #10;
firsttoken : boolean = TRUE;
operandnum : byte = 0;
charcount: byte = 0;
var
p : paasmoutput;
actasmtoken: tinteltoken;
actasmpattern: string;
c: char;
Instr: TInstruction;
labellist: TAsmLabelList;
line: string; { CHanged from const to var, there is a bug in 0.9.1 which
doesn't allow 255-char constant strings. MVC}
Procedure SetupTables;
{ creates uppercased symbol tables. }
var
i: tasmop;
j: tregister;
Begin
Message(assem_d_creating_lookup_tables);
{ opcodes }
new(iasmops);
for i:=firstop to lastop do
iasmops^[i] := upper(att_op2str[i]);
{ opcodes }
for j:=firstreg to lastreg do
iasmregs[j] := upper(att_reg2str[j]);
end;
{---------------------------------------------------------------------}
{ Routines for the tokenizing }
{---------------------------------------------------------------------}
function is_asmopcode(const s: string):Boolean;
{*********************************************************************}
{ FUNCTION is_asmopcode(s: string):Boolean }
{ Description: Determines if the s string is a valid opcode }
{ if so returns TRUE otherwise returns FALSE. }
{*********************************************************************}
var
i: tasmop;
j: byte;
hs: topsize;
hid: string;
Begin
is_asmopcode := FALSE;
{ first search for extended opcodes }
for j:=0 to _count_asmspecialops do
Begin
if s = _specialops[j] then
Begin
is_asmopcode:=TRUE;
exit;
end;
end;
for i:=firstop to lastop do
Begin
if s=iasmops^[i] then
begin
is_asmopcode := TRUE;
exit
end;
end;
{ not found yet ... }
{ search for all possible suffixes }
for hs:=S_WL downto S_B do
if copy(s,length(s)-length(att_opsize2str[hs])+1,
length(att_opsize2str[hs]))=upper(att_opsize2str[hs]) then
begin
{ here we search the entire table... }
hid:=copy(s,1,length(s)-length(att_opsize2str[hs]));
for i:=firstop to lastop do
if (length(hid) > 0) and (hid=iasmops^[i]) then
begin
is_asmopcode := TRUE;
exit;
end;
end;
end;
Procedure is_asmdirective(const s: string; var token: tinteltoken);
{*********************************************************************}
{ FUNCTION is_asmdirective(s: string; var token: tinteltoken):Boolean }
{ Description: Determines if the s string is a valid directive }
{ (an operator can occur in operand fields, while a directive cannot) }
{ if so returns the directive token, otherwise does not change token.}
{*********************************************************************}
var
i:byte;
Begin
for i:=0 to _count_asmdirectives do
begin
if s=_asmdirectives[i] then
begin
token := tinteltoken(longint(firstdirective)+i);
exit;
end;
end;
end;
Procedure is_register(const s: string; var token: tinteltoken);
{*********************************************************************}
{ PROCEDURE is_register(s: string; var token: tinteltoken); }
{ Description: Determines if the s string is a valid register, if }
{ so return token equal to A_REGISTER, otherwise does not change token}
{*********************************************************************}
Var
i: tregister;
Begin
for i:=firstreg to lastreg do
begin
if s=iasmregs[i] then
begin
token := AS_REGISTER;
exit;
end;
end;
end;
Function GetToken: tinteltoken;
{*********************************************************************}
{ FUNCTION GetToken: tinteltoken; }
{ Description: This routine returns intel assembler tokens and }
{ does some minor syntax error checking. }
{*********************************************************************}
var
token: tinteltoken;
forcelabel: boolean;
errorflag : boolean;
temp: string;
code: integer;
value: byte;
begin
errorflag := FALSE;
forcelabel := FALSE;
actasmpattern :='';
{* INIT TOKEN TO NOTHING *}
token := AS_NONE;
{ while space and tab , continue scan... }
while (c = ' ') or (c = #9) do
begin
c := asmgetchar;
end;
{ Possiblities for first token in a statement: }
{ Local Label, Label, Directive, Prefix or Opcode.... }
if firsttoken and not (c in [newline,#13,'{',';']) then
begin
firsttoken := FALSE;
{ directive or local labe }
if c = '.' then
begin
actasmpattern := c;
{ Let us point to the next character }
c := asmgetchar;
while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do
begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
{ this is a local label... }
if (actasmpattern[2] = 'L') and (c = ':') then
Begin
{ local variables are case sensitive }
gettoken := AS_LLABEL;
{ delete .L }
delete(actasmpattern,1,1);
delete(actasmpattern,1,1);
{ point to next character ... }
c := asmgetchar;
exit;
end
{ must be a directive }
else
Begin
{ directives are case sensitive!! }
is_asmdirective(actasmpattern, token);
if (token <> AS_NONE) then
Begin
gettoken := token;
exit;
end
else
Message1(assem_e_not_directive_or_local_symbol,actasmpattern);
end;
end; { endif }
if c='/' then
begin
c:=asmgetchar;
{ att styled comment }
if c='/' then
begin
repeat
c:=asmgetchar;
until c=newline;
firsttoken := TRUE;
gettoken:=AS_SEPARATOR;
c:=asmgetchar;
exit;
end
else
Message(assem_e_slash_at_begin_of_line_not_allowed);
end;
{ only opcodes and global labels are allowed now. }
while c in ['A'..'Z','a'..'z','0'..'9','_'] do
begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
if c = ':' then
begin
uppervar(actasmpattern);
token := AS_LABEL;
{ let us point to the next character }
c := asmgetchar;
gettoken := token;
exit;
end;
If is_asmopcode(upper(actasmpattern)) then
Begin
uppervar(actasmpattern);
gettoken := AS_OPCODE;
exit;
end
else
if upper(actasmpattern) = 'END' then
begin
gettoken := AS_END;
exit;
end
else
begin
gettoken := AS_NONE;
Message(assem_e_invalid_operand);
end;
end
else { else firsttoken }
{ Here we must handle all possible cases }
begin
case c of
'.': { possiblities : - local label reference , such as in jmp @local1 }
{ - directive. }
begin
actasmpattern := c;
c:= asmgetchar;
while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do
begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
is_asmdirective(actasmpattern,token);
{ if directive }
if (token <> AS_NONE) then
begin
gettoken := token;
exit;
end;
{ local label references and directives }
{ are case sensitive }
gettoken := AS_ID;
exit;
end;
{ identifier, register, opcode, prefix or directive }
'_','A'..'Z','a'..'z': begin
actasmpattern := c;
c:= asmgetchar;
while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do
begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
{ pascal is not case sensitive! }
{ therefore variables which are }
{ outside the scope of the asm }
{ block, should not be made case }
{ sensitive... !!!!! }
uppervar(actasmpattern);
If is_asmopcode(actasmpattern) then
Begin
gettoken := AS_OPCODE;
exit;
end;
{ we handle this directive separately from }
{ others. }
if actasmpattern = 'END' then
Begin
gettoken := AS_END;
exit;
end;
{ if found }
if (token <> AS_NONE) then
begin
gettoken := token;
exit;
end
{ this is surely an identifier }
else
token := AS_ID;
gettoken := token;
exit;
end;
'&': begin
c:=asmgetchar;
gettoken := AS_AND;
end;
{ character }
'''' : begin
c:=asmgetchar;
if c = '\' then
Begin
{ escape sequence }
c:=asmgetchar;
case c of
newline: Message(scan_f_string_exceeds_line);
't': actasmpattern:=#09;
'b': actasmpattern:=#08;
'\': actasmpattern:='\';
'f': actasmpattern:=#12;
'n': actasmpattern:=#10;
'r': actasmpattern:=#13;
'"': actasmpattern:='"';
{ octal number }
'0'..'7':
begin
temp:=c;
temp:=temp+asmgetchar;
temp:=temp+asmgetchar;
val(octaltodec(temp),value,code);
if (code <> 0) then
Message1(assem_e_error_in_octal_const,temp);
actasmpattern:=chr(value);
end;
{ hexadecimal number }
'x':
begin
temp:=asmgetchar;
temp:=temp+asmgetchar;
val(hextodec(temp),value,code);
if (code <> 0) then
Message1(assem_e_error_in_hex_const,temp);
actasmpattern:=chr(value);
end;
else
Begin
Message(assem_e_escape_seq_ignored);
actasmpattern:=c;
end
end; { end case }
end
else
actasmpattern:=c;
gettoken := AS_STRING;
c:=asmgetchar;
exit;
end;
{ string }
'"' :
begin
actasmpattern:='';
while true do
Begin
c:=asmgetchar;
case c of
'\': Begin
{ escape sequences }
c:=asmgetchar;
case c of
newline: Message(scan_f_string_exceeds_line);
't': actasmpattern:=actasmpattern+#09;
'b': actasmpattern:=actasmpattern+#08;
'\': actasmpattern:=actasmpattern+'\';
'f': actasmpattern:=actasmpattern+#12;
'n': actasmpattern:=actasmpattern+#10;
'r': actasmpattern:=actasmpattern+#13;
'"': actasmpattern:=actasmpattern+'"';
{ octal number }
'0'..'7':
begin
temp:=c;
temp:=temp+asmgetchar;
temp:=temp+asmgetchar;
val(octaltodec(temp),value,code);
if (code <> 0) then
Message1(assem_e_error_in_octal_const,temp);
actasmpattern:=actasmpattern+chr(value);
end;
{ hexadecimal number }
'x':
begin
temp:=asmgetchar;
temp:=temp+asmgetchar;
val(hextodec(temp),value,code);
if (code <> 0) then
Message1(assem_e_error_in_hex_const,temp);
actasmpattern:=actasmpattern+chr(value);
end;
else
Begin
Message(assem_e_escape_seq_ignored);
actasmpattern:=actasmpattern+c;
end
end; { end case }
end;
'"': begin
c:=asmgetchar;
break;
end;
newline: Message(scan_f_string_exceeds_line);
else
actasmpattern:=actasmpattern+c;
end;
end; { end case }
token := AS_STRING;
gettoken := token;
exit;
end;
'$' : begin
gettoken := AS_DOLLAR;
c:=asmgetchar;
exit;
end;
',' : begin
gettoken := AS_COMMA;
c:=asmgetchar;
exit;
end;
'<' : begin
gettoken := AS_SHL;
c := asmgetchar;
if c = '<' then
c := asmgetchar;
exit;
end;
'>' : begin
gettoken := AS_SHL;
c := asmgetchar;
if c = '>' then
c := asmgetchar;
exit;
end;
'|' : begin
gettoken := AS_OR;
c := asmgetchar;
exit;
end;
'^' : begin
gettoken := AS_XOR;
c := asmgetchar;
exit;
end;
'!' : begin
Message(assem_e_nor_not_supported);
c := asmgetchar;
gettoken := AS_NONE;
exit;
end;
'(' : begin
gettoken := AS_LPAREN;
c:=asmgetchar;
exit;
end;
')' : begin
gettoken := AS_RPAREN;
c:=asmgetchar;
exit;
end;
':' : begin
gettoken := AS_COLON;
c:=asmgetchar;
exit;
end;
'+' : begin
gettoken := AS_PLUS;
c:=asmgetchar;
exit;
end;
'-' : begin
gettoken := AS_MINUS;
c:=asmgetchar;
exit;
end;
'*' : begin
gettoken := AS_STAR;
c:=asmgetchar;
exit;
end;
'/' : begin
c:=asmgetchar;
{ att styled comment }
if c='/' then
begin
repeat
c:=asmgetchar;
until c=newline;
firsttoken := TRUE;
gettoken:=AS_SEPARATOR;
c:=asmgetchar;
exit;
end
else
begin
gettoken := AS_SLASH;
c:=asmgetchar;
exit;
end;
end;
{ register or modulo }
{ only register supported }
{ for the moment. }
'%' : begin
actasmpattern := c;
c:=asmgetchar;
while c in ['a'..'z','A'..'Z','0'..'9'] do
Begin
actasmpattern := actasmpattern + c;
c:=asmgetchar;
end;
token := AS_NONE;
uppervar(actasmpattern);
if (actasmpattern = '%ST') and (c='(') then
Begin
actasmpattern:=actasmpattern+c;
c:=asmgetchar;
if c in ['0'..'9'] then
actasmpattern := actasmpattern + c
else
Message(assem_e_invalid_fpu_register);
c:=asmgetchar;
if c <> ')' then
Message(assem_e_invalid_fpu_register)
else
Begin
actasmpattern := actasmpattern + c;
c:=asmgetchar; { let us point to next character. }
end;
end;
is_register(actasmpattern, token);
{ if found }
if (token <> AS_NONE) then
begin
gettoken := token;
exit;
end
else
Message(assem_w_modulo_not_supported);
end;
{ integer number }
'1'..'9': begin
actasmpattern := c;
c := asmgetchar;
while c in ['0'..'9'] do
Begin
actasmpattern := actasmpattern + c;
c:= asmgetchar;
end;
gettoken := AS_INTNUM;
exit;
end;
'0': begin
{ octal,hexa,real or binary number. }
actasmpattern := c;
c:=asmgetchar;
case upcase(c) of
{ binary }
'B': Begin
c:=asmgetchar;
while c in ['0','1'] do
Begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
gettoken := AS_BINNUM;
exit;
end;
{ real }
'D': Begin
c:=asmgetchar;
{ get ridd of the 0d }
if (c='+') or (c='-') then
begin
actasmpattern:=c;
c:=asmgetchar;
end
else
actasmpattern:='';
while c in ['0'..'9'] do
Begin
actasmpattern := actasmpattern + c;
c:= asmgetchar;
end;
if c='.' then
begin
actasmpattern := actasmpattern + c;
c:=asmgetchar;
while c in ['0'..'9'] do
Begin
actasmpattern := actasmpattern + c;
c:= asmgetchar;
end;
if upcase(c) = 'E' then
begin
actasmpattern := actasmpattern + c;
c:=asmgetchar;
if (c = '+') or (c = '-') then
begin
actasmpattern := actasmpattern + c;
c:=asmgetchar;
end;
while c in ['0'..'9'] do
Begin
actasmpattern := actasmpattern + c;
c:= asmgetchar;
end;
end;
gettoken := AS_REALNUM;
exit;
end
else
Message1(assem_e_invalid_float_const,actasmpattern+c);
end;
{ hexadecimal }
'X': Begin
c:=asmgetchar;
while c in ['0'..'9','a'..'f','A'..'F'] do
Begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
gettoken := AS_HEXNUM;
exit;
end;
{ octal }
'1'..'7': begin
actasmpattern := actasmpattern + c;
while c in ['0'..'7'] do
Begin
actasmpattern := actasmpattern + c;
c := asmgetchar;
end;
gettoken := AS_OCTALNUM;
exit;
end;
else { octal number zero value...}
Begin
gettoken := AS_OCTALNUM;
exit;
end;
end; { end case }
end;
'{',#13,newline,';' : begin
{ the comment is read by asmgetchar }
c:=asmgetchar;
firsttoken := TRUE;
gettoken:=AS_SEPARATOR;
end;
else
Begin
Message(scan_f_illegal_char);
end;
end; { end case }
end; { end else if }
end;
{---------------------------------------------------------------------}
{ Routines for the output }
{---------------------------------------------------------------------}
{ looks for internal names of variables and routines }
Function SearchDirectVar(var Instr: TInstruction; const hs:string;operandnum:byte): Boolean;
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
{ get symbol name }
{ free the memory before changing the symbol name. }
if assigned(instr.operands[operandnum].ref.symbol) then
FreeMem(instr.operands[operandnum].ref.symbol,
length(instr.operands[operandnum].ref.symbol^)+1);
instr.operands[operandnum].ref.symbol:=newpasstr(strpas(p^.name));
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_Q;
EXT_TBYTE : instr.operands[operandnum].size := S_X;
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;
SearchDirectVar := TRUE;
Exit;
end;
end;
{ returns an appropriate ao_xxxx flag indicating the type }
{ of operand. }
function findtype(Var Opr: TOperand): longint;
Begin
With Opr do
Begin
case operandtype of
OPR_REFERENCE: Begin
if assigned(ref.symbol) then
{ check if in local label list }
{ if so then it is considered }
{ as a displacement. }
Begin
if labellist.search(ref.symbol^) <> nil then
findtype := ao_disp
else
findtype := ao_mem; { probably a mem ref. }
end
else
findtype := ao_mem;
end;
OPR_CONSTANT: Begin
{ check if there is not already a default size }
if opr.size <> S_NO then
Begin
findtype := _constsizes[opr.size];
exit;
end;
if val < $ff then
Begin
findtype := ao_imm8;
opr.size := S_B;
end
else if val < $ffff then
Begin
findtype := ao_imm16;
opr.size := S_W;
end
else
Begin
findtype := ao_imm32;
opr.size := S_L;
end
end;
OPR_REGISTER: Begin
findtype := _regtypes[reg];
exit;
end;
OPR_NONE: Begin
findtype := 0;
end;
else
Begin
Message(assem_f_internal_error_in_findtype);
end;
end;
end;
end;
Procedure HandleExtend(var instr: TInstruction);
{ Handles MOVZX, MOVSX ... }
var
instruc: tasmop;
opsize: topsize;
Begin
instruc:=instr.getinstruction;
{ if we have A_MOVZX/A_MOVSX here, there is a big problem }
{ it should never happen, because it is already replaced }
{ by ConcatOpcode! }
if (instruc in [A_MOVZX,A_MOVSX]) then
Message(assem_f_internal_error_in_handleextend)
else
if (instruc = A_MOVSB) or (instruc = A_MOVSBL)
or (instruc = A_MOVSBW) or (instruc = A_MOVSWL) then
instruc := A_MOVSX
else
if (instruc = A_MOVZB) or (instruc = A_MOVZWL) then
instruc := A_MOVZX;
With instr do
Begin
if operands[1].size = S_B then
Begin
if operands[2].size = S_L then
opsize := S_BL
else
if operands[2].size = S_W then
opsize := S_BW
else
begin
Message(assem_e_invalid_size_movzx);
exit;
end;
end
else
if operands[1].size = S_W then
Begin
if operands[2].size = S_L then
opsize := S_WL
else
begin
Message(assem_e_invalid_size_movzx);
exit;
end;
end
else
begin
Message(assem_e_invalid_size_movzx);
exit;
end;
if operands[1].operandtype = OPR_REGISTER then
Begin
if operands[2].operandtype <> OPR_REGISTER then
Message(assem_e_invalid_opcode) { exit...}
else
p^.concat(new(pai386,op_reg_reg(instruc,opsize,
operands[1].reg,operands[2].reg)));
end
else
if operands[1].operandtype = OPR_REFERENCE then
Begin
if operands[2].operandtype <> OPR_REGISTER then
Message(assem_e_invalid_opcode) {exit...}
else
p^.concat(new(pai386,op_ref_reg(instruc,opsize,
newreference(operands[1].ref),operands[2].reg)));
end
end; { end with }
end;
Procedure ConcatOpCode(var instr: TInstruction);
{*********************************************************************}
{ First Pass: }
{ - If this is a three operand opcode: }
{ imul,shld,and shrd -> check them manually. }
{*********************************************************************}
var
fits : boolean;
i: longint;
opsize: topsize;
optyp1, optyp2, optyp3: longint;
instruc: tasmop;
Begin
fits := FALSE;
for i:=1 to instr.numops do
Begin
case instr.operands[i].operandtype of
OPR_REGISTER: instr.operands[i].size :=
_regsizes[instr.operands[i].reg];
end; { end case }
end; { endif }
{ setup specific instructions for first pass }
instruc := instr.getinstruction;
if (instruc in [A_LEA,A_LDS,A_LSS,A_LES,A_LFS,A_LGS]) then
Begin
if instr.operands[2].size <> S_L then
Begin
Message(assem_e_16bit_base_in_32bit_segment);
exit;
end; { endif }
end;
With instr do
Begin
for i:=1 to numops do
Begin
With operands[i] do
Begin
{ check for 16-bit bases/indexes and emit an error. }
{ we cannot only emit a warning since gas does not }
{ accept 16-bit indexes and bases. }
if (operandtype = OPR_REFERENCE) and
((ref.base <> R_NO) or
(ref.index <> R_NO)) then
Begin
{ index or base defined. }
if (ref.base <> R_NO) then
Begin
if not (ref.base in
[R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESI,R_EDI,R_ESP]) then
Message(assem_e_16bit_base_in_32bit_segment);
end;
{ index or base defined. }
if (ref.index <> R_NO) then
Begin
if not (ref.index in
[R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESI,R_EDI,R_ESP]) then
Message(assem_e_16bit_index_in_32bit_segment);
end;
end;
{ Check for constants without bases/indexes in memory }
{ references. }
if (operandtype = OPR_REFERENCE) and
(ref.base = R_NO) and
(ref.index = R_NO) and
(ref.symbol = nil) and
(ref.offset <> 0) then
Begin
ref.isintvalue := TRUE;
Message(assem_e_const_ref_not_allowed);
end;
opinfo := findtype(operands[i]);
end; { end with }
end; {endfor}
{ TAKE CARE OF SPECIAL OPCODES, TAKE CARE OF THEM INDIVUALLY. }
{ ALL THE REST ARE TAKEN CARE BY OPCODE TABLE AND THIRD PASS. }
{ is this right for ratti386 ? (PM) }
{ almost... here we check for the size of registers and references }
{ to determine the correct gas opcode to use, because if the token }
{ is A_MOVSX or A_MOVZX then that means that the person forgot to }
{ specify the size.. }
{ if memory size is not specified, will of course give out an error}
if instruc = A_MOVSX then
Begin
if numops = 2 then
begin
if stropsize = S_BL then
begin
operands[1].size := S_B;
stropsize := S_NO;
operands[2].size := S_L;
addinstr(A_MOVSBL)
end
else
if stropsize = S_WL then
begin
operands[1].size := S_W;
stropsize := S_NO;
operands[2].size := S_L;
addinstr(A_MOVSWL)
end
else
if stropsize = S_BW then
begin
operands[1].size := S_B;
stropsize := S_NO;
operands[2].size := S_W;
addinstr(A_MOVSBW)
end
else
if (operands[1].size = S_B) and (operands[2].size = S_W) then
addinstr(A_MOVSBW)
else
if (operands[1].size = S_B) and (operands[2].size = S_L) then
addinstr(A_MOVSBL)
else
if (operands[1].size = S_W) and (operands[2].size = S_L) then
addinstr(A_MOVSWL)
else
begin
Message(assem_e_invalid_size_movzx);
exit;
end;
instruc := getinstruction; { reload instruction }
end
else
begin
Message(assem_e_too_many_operands);
exit;
end;
end
else
if instruc = A_MOVZX then
Begin
if numops = 2 then
Begin
if stropsize = S_BW then
begin
operands[1].size := S_B;
stropsize := S_NO;
operands[2].size := S_W;
addinstr(A_MOVZB)
end
else
if stropsize = S_BL then
begin
operands[1].size := S_B;
stropsize := S_NO;
operands[2].size := S_L;
addinstr(A_MOVZB)
end
else
if stropsize = S_WL then
begin
operands[1].size := S_W;
stropsize := S_NO;
operands[2].size := S_L;
addinstr(A_MOVZWL)
end
else
{ change the instruction to conform to GAS }
if (operands[1].size = S_B) and (operands[2].size in [S_W,S_L]) then
addinstr(A_MOVZB)
else
if (operands[1].size = S_W) and (operands[2].size = S_L) then
addinstr(A_MOVZWL)
else
begin
Message(assem_e_invalid_size_movzx);
exit;
end;
instruc := getinstruction; { reload instruction }
end
else
Begin
Message(assem_e_too_many_operands);
exit;
end;
end
else
if instruc = A_FWAIT then
FWaitWarning
else
if (instruc in [A_BT,A_BTC,A_BTR,A_BTS]) then
Begin
if numops = 2 then
Begin
if (operands[1].operandtype = OPR_CONSTANT)
and (operands[1].val <= $ff) then
Begin
operands[1].opinfo := ao_imm8;
{ no operand size if using constant. }
operands[1].size := S_NO;
fits := TRUE;
end
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
else
if instruc = A_ENTER then
Begin
if numops =2 then
Begin
if (operands[1].operandtype = OPR_CONSTANT) and
(operands[1].val <= $ffff) then
Begin
operands[1].opinfo := ao_imm16;
end { endif }
end { endif }
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end
end { endif }
else
{ Handle special opcodes for the opcode }
{ table. Set them up correctly. }
if (instruc in [A_INS,A_IN]) then
Begin
if numops =2 then
Begin
if (operands[1].operandtype = OPR_REGISTER) and (operands[1].reg = R_DX)
then
Begin
operands[1].opinfo := ao_inoutportreg;
if (operands[2].operandtype = OPR_REGISTER) and
(operands[2].reg in [R_EAX,R_AX,R_AL]) and
(instruc = A_IN) then
Begin
operands[2].opinfo := ao_acc;
end
end
else
if (operands[1].operandtype = OPR_CONSTANT) and (operands[1].val <= $ff)
and (instruc = A_IN) then
Begin
operands[1].opinfo := ao_imm8;
operands[1].size := S_B;
if (operands[2].operandtype = OPR_REGISTER) and
(operands[2].reg in [R_EAX,R_AX,R_AL]) and
(instruc = A_IN) then
Begin
operands[2].opinfo := ao_acc;
end
end;
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
else
if (instruc in [A_OUTS,A_OUT]) then
Begin
if numops =2 then
Begin
if (operands[2].operandtype = OPR_REGISTER) and (operands[2].reg = R_DX)
then
Begin
operands[2].opinfo := ao_inoutportreg;
if (operands[1].operandtype = OPR_REGISTER) and
(operands[1].reg in [R_EAX,R_AX,R_AL]) and
(instruc = A_OUT) then
Begin
operands[1].opinfo := ao_acc;
fits := TRUE;
end
end
else
if (operands[2].operandtype = OPR_CONSTANT) and (operands[2].val <= $ff)
and (instruc = A_OUT) then
Begin
operands[2].opinfo := ao_imm8;
operands[2].size := S_B;
if (operands[1].operandtype = OPR_REGISTER) and
(operands[1].reg in [R_EAX,R_AX,R_AL]) and
(instruc = A_OUT) then
Begin
operands[1].opinfo := ao_acc;
fits := TRUE;
end
end;
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
else
if instruc in [A_RCL,A_RCR,A_ROL,A_ROR,A_SAL,A_SAR,A_SHL,A_SHR] then
{ if RCL,ROL,... }
Begin
if numops =2 then
Begin
if (operands[1].operandtype = OPR_REGISTER) and (operands[1].reg = R_CL)
then
Begin
operands[1].opinfo := ao_shiftcount
end
else
if (operands[1].operandtype = OPR_CONSTANT) and
(operands[1].val <= $ff) then
Begin
operands[1].opinfo := ao_imm8;
operands[1].size := S_B;
end;
end
else { if numops = 2 }
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
{ endif ROL,RCL ... }
else
{ this did not work (PM) }
if instruc in [A_DIV, A_IDIV] then
Begin
if (operands[2].operandtype = OPR_REGISTER) and
(operands[2].reg in [R_AL,R_AX,R_EAX]) then
operands[2].opinfo := ao_acc;
end
else
if (instruc = A_FNSTSW) or (instruc = A_FSTSW) then
Begin
{ %ax can be omitted in ATT syntax }
if numops = 0 then
Begin
numops:=1;
operands[1].operandtype:=OPR_REGISTER;
operands[1].reg:=R_AX;
operands[1].opinfo := ao_acc;
end
else if numops = 1 then
Begin
if (operands[1].operandtype = OPR_REGISTER) and
(operands[1].reg = R_AX) then
operands[1].opinfo := ao_acc;
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
else
if (instruc = A_SHLD) or (instruc = A_SHRD) then
{ these instruction are fully parsed individually on pass three }
{ so we just do a summary checking here. }
Begin
if numops = 3 then
Begin
if (operands[3].operandtype = OPR_CONSTANT)
and (operands[3].val <= $ff) then
Begin
operands[3].opinfo := ao_imm8;
operands[3].size := S_B;
end;
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
end
else
if instruc = A_INT then
Begin
if numops = 1 then
Begin
if (operands[1].operandtype = OPR_CONSTANT) and
(operands[1].val <= $ff) then
operands[1].opinfo := ao_imm8;
end
end
else
if instruc = A_RET then
Begin
if numops =1 then
Begin
if (operands[1].operandtype = OPR_CONSTANT) and
(operands[1].val <= $ffff) then
operands[1].opinfo := ao_imm16;
end
end; { endif }
{ all string instructions have default memory }
{ location which are ignored. Take care of }
{ those. }
{ Here could be added the code for segment }
{ overrides. }
if instruc in [A_SCAS,A_CMPS,A_STOS,A_LODS] then
Begin
if numops =1 then
Begin
if (operands[1].operandtype = OPR_REFERENCE) and
(assigned(operands[1].ref.symbol)) then
Freemem(operands[1].ref.symbol,length(operands[1].ref.symbol^)+1);
operands[1].operandtype := OPR_NONE;
numops := 0;
end;
end; { endif }
if instruc in [A_INS,A_MOVS,A_OUTS] then
Begin
if numops =2 then
Begin
if (operands[2].operandtype = OPR_REFERENCE) and
(assigned(operands[2].ref.symbol)) then
Freemem(operands[2].ref.symbol,length(operands[2].ref.symbol^)+1);
if (operands[1].operandtype = OPR_REFERENCE) and
(assigned(operands[1].ref.symbol)) then
Freemem(operands[1].ref.symbol,length(operands[2].ref.symbol^)+1);
operands[2].operandtype := OPR_NONE;
operands[1].operandtype := OPR_NONE;
numops := 0;
end;
end;
{ handle parameter for segment overrides }
if instruc = A_XLAT then
Begin
{ handle special TP syntax case for XLAT }
{ here we accept XLAT, XLATB and XLAT m8 }
if (numops = 1) or (numops = 0) then
Begin
if (operands[1].operandtype = OPR_REFERENCE) and
(assigned(operands[1].ref.symbol)) then
Freemem(operands[1].ref.symbol,length(operands[1].ref.symbol^)+1);
operands[1].operandtype := OPR_NONE;
numops := 0;
{ always a byte for XLAT }
instr.stropsize := S_B;
end;
end
else
{ ------------------------------------------------------------------- }
{ ------------------------- SIZE CHECK ------------------------------ }
{ ------------- presently done only for most used opcodes ---------- }
{ Checks if the suffix concords with the destination size , if }
{ not gives out an error. (This check is stricter then gas but is }
{ REQUIRED for intasmi3) }
if instruc in [A_MOV,A_ADD,A_SUB,A_ADC,A_SBB,A_CMP,A_AND,A_OR,A_TEST,A_XOR] then
begin
if (instr.stropsize <> S_NO) and (instr.operands[2].size <> S_NO) then
if (instr.stropsize <> instr.operands[2].size) then
begin
Message(assem_e_size_suffix_and_dest_reg_dont_match);
exit;
end;
end
else
if instruc in [A_DEC,A_INC,A_NOT,A_NEG] then
begin
if (instr.stropsize <> S_NO) and (instr.operands[1].size <> S_NO) then
if (instr.stropsize <> instr.operands[1].size) then
begin
Message(assem_e_size_suffix_and_dest_reg_dont_match);
exit;
end;
end;
{ ------------------------------------------------------------------- }
{ copy them to local variables }
{ for faster access }
optyp1:=operands[1].opinfo;
optyp2:=operands[2].opinfo;
optyp3:=operands[3].opinfo;
end; { end with }
{ after reading the operands }
{ search the instruction }
{ setup startvalue from cache }
if ins_cache[instruc]<>-1 then
i:=ins_cache[instruc]
else i:=0;
{ I think this is too dangerous for me therefore i decided that for }
{ the att version only if the processor > i386 or we are compiling }
{ the system unit then this will be allowed... }
if (instruc >= lastop_in_table) and
((cs_compilesystem in aktswitches) or (opt_processors > globals.i386)) then
begin
Message1(assem_w_opcode_not_in_table,att_op2str[instruc]);
fits:=true;
end
else while not(fits) do
begin
{ set the instruction cache, if the instruction }
{ occurs the first time }
if (it[i].i=instruc) and (ins_cache[instruc]=-1) then
ins_cache[instruc]:=i;
if (it[i].i=instruc) and (instr.numops=it[i].ops) then
begin
{ first fit }
case instr.numops of
0 : begin
fits:=true;
break;
end;
1 :
Begin
if (optyp1 and it[i].o1)<>0 then
Begin
fits:=true;
break;
end;
{ I consider sign-extended 8bit value to }
{ be equal to immediate 8bit therefore }
{ convert... }
if (optyp1 = ao_imm8) then
Begin
{ check if this is a simple sign extend. }
if (it[i].o1<>ao_imm8s) then
Begin
fits:=true;
break;
end;
end;
end;
2 : if ((optyp1 and it[i].o1)<>0) and
((optyp2 and it[i].o2)<>0) then
Begin
fits:=true;
break;
end
{ if the operands can be swaped }
{ then swap them }
else if ((it[i].m and af_d)<>0) and
((optyp1 and it[i].o2)<>0) and
((optyp2 and it[i].o1)<>0) then
begin
fits:=true;
break;
end;
3 : if ((optyp1 and it[i].o1)<>0) and
((optyp2 and it[i].o2)<>0) and
((optyp3 and it[i].o3)<>0) then
Begin
fits:=true;
break;
end;
end; { end case }
end; { endif }
if it[i].i=A_NONE then
begin
{ NO MATCH! }
Message(assem_e_invalid_opcode_and_operand);
exit;
end;
inc(i);
end; { end while }
{ We add the opcode to the opcode linked list }
if fits then
Begin
if instr.getprefix <> A_NONE then
Begin
p^.concat(new(pai386,op_none(instr.getprefix,S_NO)));
end;
{ change from AT&T styled floating point to }
{ intel styled floating point with valid size }
{ we use these instructions so it does not }
{ mess up intasmi3 }
if (instruc >= A_FILDQ) and (instruc <= A_FIDIVRS) then
Begin
instr.stropsize := _fpusizes[instruc];
instr.addinstr(_fpuopcodes[instruc]);
instruc := instr.getinstruction;
end;
case instr.numops of
0:
if instr.stropsize <> S_NO then
{ is this a string operation opcode or xlat then check }
{ the size of the operation. }
p^.concat(new(pai386,op_none(instruc,instr.stropsize)))
else
p^.concat(new(pai386,op_none(instruc,S_NO)));
1: Begin
case instr.operands[1].operandtype of
{ all one operand opcodes with constant have no defined sizes }
{ at least that is what it seems in the tasm 2.0 manual. }
OPR_CONSTANT: p^.concat(new(pai386,op_const(instruc,
S_NO, instr.operands[1].val)));
{ the size of the operand can be determined by the as,nasm and }
{ tasm -- see note in rai386.pas }
OPR_REGISTER: p^.concat(new(pai386,op_reg(instruc,
S_NO,instr.operands[1].reg)));
OPR_REFERENCE:
{ now first check suffix ... }
if instr.stropsize <> S_NO then
Begin
p^.concat(new(pai386,op_ref(instruc,
instr.stropsize,newreference(instr.operands[1].ref))));
end
{ no suffix... therefore resort using intel styled checking .. }
else
if instr.operands[1].size <> S_NO then
Begin
p^.concat(new(pai386,op_ref(instruc,
instr.operands[1].size,newreference(instr.operands[1].ref))));
end
else
Begin
{ special jmp and call case with }
{ symbolic references. }
if (instruc in [A_CALL,A_JMP]) or
(instruc = A_FNSTCW) or
(instruc = A_FSTCW) or
(instruc = A_FLDCW) or
(instruc = A_FNSTSW) or
(instruc = A_FSTSW) or
(instruc = A_FLDENV) or
(instruc = A_FSTENV) or
(instruc = A_FNSAVE) or
(instruc = A_FSAVE) then
Begin
p^.concat(new(pai386,op_ref(instruc,
S_NO,newreference(instr.operands[1].ref))));
end
else
Message(assem_e_invalid_opcode_and_operand);
end;
{ This either crashed the compiler or the symbol would always be nil! }
{ The problem is here is I didn't see any way of adding the labeled }
{ symbol in the internal list, since i think from what i see in aasm }
{ that these will automatically be declared as external ?? }
{ if (instruc in [A_JO,A_JNO,A_JB,A_JC,A_JNAE,
A_JNB,A_JNC,A_JAE,A_JE,A_JZ,A_JNE,A_JNZ,A_JBE,A_JNA,A_JNBE,
A_JA,A_JS,A_JNS,A_JP,A_JPE,A_JNP,A_JPO,A_JL,A_JNGE,A_JNL,A_JGE,
A_JLE,A_JNG,A_JNLE,A_JG,A_JCXZ,A_JECXZ,A_LOOP,A_LOOPZ,A_LOOPE,
A_LOOPNZ,A_LOOPNE,A_JMP,A_CALL]) then
Begin
if assigned(instr.operands[1].ref.symbol) then
p^.concat(new(pai386,op_csymbol(instruc,
S_NO,newcsymbol(instr.operands[1].ref.symbol^,instr.operands[1].ref.offset))))
else
Message(assem_e_invalid_opcode_and_operand);
end
else
else
Message(assem_e_invalid_opcode_and_operand);
end;}
OPR_NONE: Begin
Message(assem_f_internal_error_in_concatopcode);
end;
else
Begin
Message(assem_f_internal_error_in_concatopcode);
end;
end;
end;
2:
Begin
if instruc in [A_MOVSX,A_MOVZX,A_MOVSB,A_MOVSBL,A_MOVSBW,
A_MOVSWL,A_MOVZB,A_MOVZWL] then
{ movzx and movsx }
HandleExtend(instr)
else
{ other instructions }
Begin
With instr do
Begin
{ source }
opsize := operands[1].size;
case operands[1].operandtype of
{ reg,reg }
{ reg,ref }
{ const,reg -- IN/OUT }
OPR_REGISTER:
Begin
case operands[2].operandtype of
OPR_REGISTER:
{ correction: according to the DJGPP FAQ, gas }
{ doesn't even check correctly the size of }
{ operands, therefore let us specify a size! }
{ as in the GAS docs... destination tells us }
{ the size! This might give out invalid output }
{ in some very rare cases (because the size }
{ checking is still not perfect). }
if (opsize = operands[2].size) then
begin
p^.concat(new(pai386,op_reg_reg(instruc,
opsize,operands[1].reg,operands[2].reg)));
end
else
{ these do not require any size specification. }
if (instruc in [A_IN,A_OUT,A_SAL,A_SAR,A_SHL,A_SHR,A_ROL,
A_ROR,A_RCR,A_RCL]) then
{ outs and ins are already taken care by }
{ the first pass. }
p^.concat(new(pai386,op_reg_reg(instruc,
S_NO,operands[1].reg,operands[2].reg)))
else
if stropsize <> S_NO then
Begin
p^.concat(new(pai386,op_reg_reg(instruc,
stropsize,operands[1].reg,operands[2].reg)))
end
else
Begin
Message(assem_e_invalid_opcode_and_operand);
end;
OPR_REFERENCE:
{ variable name. }
{ here we must check the instruction type }
{ before deciding if to use and compare }
{ any sizes. }
if assigned(operands[2].ref.symbol) then
Begin
if stropsize <> S_NO then
Begin
p^.concat(new(pai386,op_reg_ref(instruc,
stropsize,operands[1].reg,newreference(operands[2].ref))))
end
else
if (opsize = operands[2].size) or (instruc in
[A_RCL,A_RCR,A_ROL,A_ROR,A_SAL,A_SAR,A_SHR,A_SHL]) then
p^.concat(new(pai386,op_reg_ref(instruc,
opsize,operands[1].reg,newreference(operands[2].ref))))
else
Message(assem_e_invalid_size_in_ref);
end
else
Begin
{ register reference }
if stropsize <> S_NO then
Begin
p^.concat(new(pai386,op_reg_ref(instruc,
stropsize,operands[1].reg,newreference(operands[2].ref))))
end
else
if (opsize = operands[2].size) or (operands[2].size = S_NO) then
p^.concat(new(pai386,op_reg_ref(instruc,
opsize,operands[1].reg,newreference(operands[2].ref))))
else
Message(assem_e_invalid_size_in_ref);
end;
OPR_CONSTANT: { OUT }
begin
{ determine first with suffix }
if instruc = A_OUT then
begin
if instr.stropsize <> S_NO then
p^.concat(new(pai386,op_reg_const(instruc,stropsize,
instr.operands[1].reg, instr.operands[2].val)))
else
p^.concat(new(pai386,op_reg_const(instruc,S_NO,
instr.operands[1].reg, instr.operands[2].val)));
end
else
Message(assem_e_invalid_opcode);
end;
else { else case }
Begin
Message(assem_f_internal_error_in_concatopcode);
end;
end; { end inner case }
end;
{ const,reg }
{ const,const }
{ const,ref }
OPR_CONSTANT:
case instr.operands[2].operandtype of
{ constant, constant does not have a specific size. }
OPR_CONSTANT:
p^.concat(new(pai386,op_const_const(instruc,
S_NO,operands[1].val,operands[2].val)));
OPR_REFERENCE:
Begin
{ check for suffix first ... }
if (instr.stropsize <> S_NO) then
Begin
p^.concat(new(pai386,op_const_ref(instruc,
stropsize,operands[1].val,
newreference(operands[2].ref))))
end
else
{ resort to intel styled checking ... }
if (operands[1].val <= $ff) and
(operands[2].size in [S_B,S_W,S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_ref(instruc,
operands[2].size,operands[1].val,
newreference(operands[2].ref))))
else
if (operands[1].val <= $ffff) and
(operands[2].size in [S_W,S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_ref(instruc,
operands[2].size,operands[1].val,
newreference(operands[2].ref))))
else
if (operands[1].val <= $7fffffff) and
(operands[2].size in [S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_ref(instruc,
operands[2].size,operands[1].val,
newreference(operands[2].ref))))
else
Message(assem_e_invalid_size_in_ref);
end;
OPR_REGISTER:
Begin
{ size of opcode determined by register }
if (operands[1].val <= $ff) and
(operands[2].size in [S_B,S_W,S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_reg(instruc,
operands[2].size,operands[1].val,
operands[2].reg)))
else
if (operands[1].val <= $ffff) and
(operands[2].size in [S_W,S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_reg(instruc,
operands[2].size,operands[1].val,
operands[2].reg)))
else
if (operands[1].val <= $7fffffff) and
(operands[2].size in [S_L,S_Q,S_S]) then
p^.concat(new(pai386,op_const_reg(instruc,
operands[2].size,operands[1].val,
operands[2].reg)))
else
Message(assem_e_invalid_opcode_size);
end;
else
Begin
Message(assem_f_internal_error_in_concatopcode);
end;
end; { end case }
{ ref,reg }
{ ref,ref }
OPR_REFERENCE:
case instr.operands[2].operandtype of
OPR_REGISTER:
if assigned(operands[1].ref.symbol) then
{ global variable }
Begin
if instruc in [A_LEA,A_LDS,A_LES,A_LFS,A_LGS,A_LSS]
then
p^.concat(new(pai386,op_ref_reg(instruc,
S_NO,newreference(operands[1].ref),
operands[2].reg)))
else
if (stropsize <> S_NO) then
Begin
p^.concat(new(pai386,op_ref_reg(instruc,
stropsize,newreference(operands[1].ref),
operands[2].reg)))
end
else
if (opsize = operands[2].size) then
p^.concat(new(pai386,op_ref_reg(instruc,
opsize,newreference(operands[1].ref),
operands[2].reg)))
else
Begin
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Begin
{ register reference }
{ possiblities:1) local variable which }
{ has been replaced by bp and offset }
{ in this case size should be valid }
{ 2) Indirect register }
{ adressing, 2nd operand determines }
{ size. }
if (stropsize <> S_NO) then
Begin
p^.concat(new(pai386,op_ref_reg(instruc,
stropsize,newreference(operands[1].ref),
operands[2].reg)))
end
else
if (opsize = operands[2].size) or (opsize = S_NO) then
Begin
p^.concat(new(pai386,op_ref_reg(instruc,
operands[2].size,newreference(operands[1].ref),
operands[2].reg)));
end
else
Message(assem_e_invalid_size_in_ref);
end;
OPR_REFERENCE: { special opcodes }
p^.concat(new(pai386,op_ref_ref(instruc,
opsize,newreference(operands[1].ref),
newreference(operands[2].ref))));
else
Begin
Message(assem_f_internal_error_in_concatopcode);
end;
end; { end inner case }
end; { end case }
end; { end with }
end; {end if movsx... }
end;
3: Begin
{ only imul, shld and shrd }
{ middle must be a register }
if (instruc in [A_SHLD,A_SHRD]) and (instr.operands[2].operandtype =
OPR_REGISTER) then
Begin
case instr.operands[2].size of
S_W: if instr.operands[1].operandtype = OPR_CONSTANT then
Begin
if instr.operands[1].val <= $ff then
Begin
if instr.operands[3].size in [S_W] then
Begin
case instr.operands[3].operandtype of
OPR_REFERENCE: { MISSING !!!! } ;
OPR_REGISTER: p^.concat(new(pai386,
op_const_reg_reg(instruc, S_W,
instr.operands[1].val, instr.operands[2].reg,
instr.operands[3].reg)));
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
S_L: if instr.operands[1].operandtype = OPR_CONSTANT then
Begin
if instr.operands[1].val <= $ff then
Begin
if instr.operands[3].size in [S_L] then
Begin
case instr.operands[3].operandtype of
OPR_REFERENCE: { MISSING !!!! } ;
OPR_REGISTER: p^.concat(new(pai386,
op_const_reg_reg(instruc, S_L,
instr.operands[1].val, instr.operands[2].reg,
instr.operands[3].reg)));
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
else
Message(assem_e_invalid_opcode_and_operand);
end; { end case }
end
else
if (instruc in [A_IMUL]) and (instr.operands[3].operandtype
= OPR_REGISTER) then
Begin
case instr.operands[3].size of
S_W: if instr.operands[1].operandtype = OPR_CONSTANT then
Begin
if instr.operands[1].val <= $ffff then
Begin
if instr.operands[2].size in [S_W] then
Begin
case instr.operands[2].operandtype of
OPR_REFERENCE: { MISSING !!!! } ;
OPR_REGISTER: p^.concat(new(pai386,
op_const_reg_reg(instruc, S_W,
instr.operands[1].val, instr.operands[2].reg,
instr.operands[3].reg)));
else
Message(assem_e_invalid_opcode_and_operand);
end; { end case }
end
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
S_L: if instr.operands[1].operandtype = OPR_CONSTANT then
Begin
if instr.operands[1].val <= $7fffffff then
Begin
if instr.operands[2].size in [S_L] then
Begin
case instr.operands[2].operandtype of
OPR_REFERENCE: { MISSING !!!! } ;
OPR_REGISTER: p^.concat(new(pai386,
op_const_reg_reg(instruc, S_L,
instr.operands[1].val, instr.operands[2].reg,
instr.operands[3].reg)));
else
Message(assem_e_invalid_opcode_and_operand);
end; { end case }
end
else
Message(assem_e_invalid_opcode_and_operand);
end;
end
else
Message(assem_e_invalid_opcode_and_operand);
else
Message(assem_e_invalid_middle_sized_operand);
end; { end case }
end { endif }
else
Message(assem_e_invalid_three_operand_opcode);
end;
end; { end case }
end;
end;
Procedure ConcatLabeledInstr(var instr: TInstruction);
Var instruct : tasmop;
i : longint;
Begin
instruct:=instr.getinstruction;
if (instruct in [A_JO,A_JNO,A_JB,A_JC,A_JNAE,
A_JNB,A_JNC,A_JAE,A_JE,A_JZ,A_JNE,A_JNZ,A_JBE,A_JNA,A_JNBE,
A_JA,A_JS,A_JNS,A_JP,A_JPE,A_JNP,A_JPO,A_JL,A_JNGE,A_JNL,A_JGE,
A_JLE,A_JNG,A_JNLE,A_JG,A_JCXZ,A_JECXZ,A_LOOP,A_LOOPZ,A_LOOPE,
A_LOOPNZ,A_LOOPNE,A_MOV,A_JMP,A_CALL]) then
Begin
if (instr.numops <> 1) then
Message(assem_e_invalid_labeled_opcode)
else if instr.operands[1].operandtype <> OPR_LABINSTR then
Message(assem_e_invalid_labeled_opcode)
else if assigned(instr.operands[1].hl) then
ConcatLabel(p,instruct, instr.operands[1].hl)
else
Begin
Message(assem_f_internal_error_in_concatlabeledinstr);
end;
end
else
if (cs_compilesystem in aktswitches) then
begin
for i:=1 to instr.numops do
if instr.operands[i].operandtype=OPR_LABINSTR then
begin
instr.operands[i].operandtype:=OPR_REFERENCE;
instr.operands[i].ref.symbol:=newpasstr(lab2str(instr.operands[i].hl) );
instr.operands[i].opinfo:=ao_mem;
instr.operands[i].ref.base:=R_NO;
instr.operands[i].ref.index:=R_NO;
instr.operands[i].ref.segment:=R_DEFAULT_SEG;
instr.operands[i].ref.offset:=0;
end;
{ handle now as an ordinary opcode }
concatopcode(instr);
end
else
Message(assem_e_invalid_operand);
end;
{---------------------------------------------------------------------}
{ Routines for the parsing }
{---------------------------------------------------------------------}
procedure consume(t : tinteltoken);
begin
if t<>actasmtoken then
Message(assem_e_syntax_error);
actasmtoken:=gettoken;
{ if the token must be ignored, then }
{ get another token to parse. }
if actasmtoken = AS_NONE then
actasmtoken := gettoken;
end;
function findregister(const s : string): tregister;
{*********************************************************************}
{ FUNCTION findregister(s: string):tasmop; }
{ Description: Determines if the s string is a valid register, }
{ if so returns correct tregister token, or R_NO if not found. }
{*********************************************************************}
var
i: tregister;
begin
findregister := R_NO;
for i:=firstreg to lastreg do
if s = iasmregs[i] then
Begin
findregister := i;
exit;
end;
end;
function findprefix(const s: string; var token: tasmop): boolean;
var i: byte;
Begin
findprefix := FALSE;
for i:=0 to _count_asmprefixes do
Begin
if s = _asmprefixes[i] then
begin
token := _prefixtokens[i];
findprefix := TRUE;
exit;
end;
end;
end;
function findsegment(const s:string): tregister;
{*********************************************************************}
{ FUNCTION findsegment(s: string):tasmop; }
{ Description: Determines if the s string is a valid segment register}
{ if so returns correct tregister token, or R_NO if not found. }
{*********************************************************************}
var
i: tregister;
Begin
findsegment := R_DEFAULT_SEG;
for i:=firstsreg to lastsreg do
if s = iasmregs[i] then
Begin
findsegment := i;
exit;
end;
end;
function findopcode(const s: string): tasmop;
{*********************************************************************}
{ FUNCTION findopcode(s: string): tasmop; }
{ Description: Determines if the s string is a valid opcode }
{ if so returns correct tasmop token. }
{*********************************************************************}
var
i: tasmop;
j: byte;
hs: topsize;
hid: string;
Begin
findopcode := A_NONE;
{ first search for extended opcodes }
{ now, in this case, we must use the suffix }
{ to determine the size of the instruction }
for j:=0 to _count_asmspecialops do
Begin
if s = _specialops[j] then
Begin
findopcode := _specialopstokens[j];
{ set the size }
case s[length(s)] of
'B': instr.stropsize := S_B;
'L': instr.stropsize := S_L;
'W': instr.stropsize := S_W;
end;
exit;
end;
end;
for i:=firstop to lastop do
Begin
if s=iasmops^[i] then
begin
findopcode := i;
instr.stropsize := S_NO;
exit;
end;
end;
{ not found yet ... }
{ search for all possible suffixes }
for hs:=S_WL downto S_B do
if copy(s,length(s)-length(att_opsize2str[hs])+1,
length(att_opsize2str[hs]))=upper(att_opsize2str[hs]) then
begin
hid:=copy(s,1,length(s)-length(att_opsize2str[hs]));
for i:=firstop to lastop do
if (length(hid) > 0) and (hid=iasmops^[i]) then
begin
findopcode := i;
instr.stropsize := hs;
exit;
end;
end;
end;
Function CheckPrefix(prefix: tasmop; opcode:tasmop): Boolean;
{ Checks if the prefix is valid with the following instruction }
{ return false if not, otherwise true }
Begin
CheckPrefix := TRUE;
Case prefix of
A_REP,A_REPNE,A_REPE: if not (opcode in [A_SCAS,A_INS,A_OUTS,A_MOVS,
A_CMPS,A_LODS,A_STOS]) then
Begin
CheckPrefix := FALSE;
exit;
end;
A_LOCK: if not (opcode in [A_BT,A_BTS,A_BTR,A_BTC,A_XCHG,A_ADD,A_OR,
A_ADC,A_SBB,A_AND,A_SUB,A_XOR,A_NOT,A_NEG,A_INC,A_DEC]) then
Begin
CheckPrefix := FALSE;
Exit;
end;
A_NONE: exit; { no prefix here }
else
CheckPrefix := FALSE;
end; { end case }
end;
Procedure InitAsmRef(var instr: TInstruction);
{*********************************************************************}
{ Description: This routine first check if the instruction 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
With instr do
Begin
case operands[operandnum].operandtype of
OPR_REFERENCE: exit;
OPR_NONE: ;
else
Message(assem_e_invalid_operand_type);
end;
operands[operandnum].operandtype := OPR_REFERENCE;
operands[operandnum].ref.segment := R_DEFAULT_SEG;
end;
end;
Function CheckOverride(segreg: tregister; var instr: TInstruction): Boolean;
{ Check if the override is valid, and if so then }
{ update the instr variable accordingly. }
Begin
CheckOverride := FALSE;
if instr.getinstruction in [A_MOVS,A_XLAT,A_CMPS] then
Begin
CheckOverride := TRUE;
Message(assem_e_segment_override_not_supported);
end
end;
Function CalculateExpression(expression: string): longint;
var
expr: TExprParse;
Begin
expr.Init;
CalculateExpression := expr.Evaluate(expression);
expr.Done;
end;
Function BuildExpression: longint;
{*********************************************************************}
{ FUNCTION BuildExpression: longint }
{ Description: This routine calculates a constant expression to }
{ a given value. The return value is the value calculated from }
{ the expression. }
{ The following tokens (not strings) are recognized: }
{ (,),SHL,SHR,/,*,NOT,OR,XOR,AND,MOD,+/-,numbers,ID to constants. }
{*********************************************************************}
{ ENTRY: On entry the token should be any valid expression token. }
{ EXIT: On Exit the token points to either COMMA or SEPARATOR }
{ ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming }
{ invalid tokens. }
{*********************************************************************}
var expr: string;
tempstr: string;
l : longint;
errorflag: boolean;
Begin
errorflag := FALSE;
expr := '';
tempstr := '';
Repeat
Case actasmtoken of
AS_LPAREN: Begin
Consume(AS_LPAREN);
expr := expr + '(';
end;
AS_RPAREN: Begin
Consume(AS_RPAREN);
expr := expr + ')';
end;
AS_SHL: Begin
Consume(AS_SHL);
expr := expr + '<';
end;
AS_SHR: Begin
Consume(AS_SHR);
expr := expr + '>';
end;
AS_SLASH: Begin
Consume(AS_SLASH);
expr := expr + '/';
end;
AS_MOD: Begin
Consume(AS_MOD);
expr := expr + '%';
end;
AS_STAR: Begin
Consume(AS_STAR);
expr := expr + '*';
end;
AS_PLUS: Begin
Consume(AS_PLUS);
expr := expr + '+';
end;
AS_MINUS: Begin
Consume(AS_MINUS);
expr := expr + '-';
end;
AS_AND: Begin
Consume(AS_AND);
expr := expr + '&';
end;
AS_NOT: Begin
Consume(AS_NOT);
expr := expr + '~';
end;
AS_XOR: Begin
Consume(AS_XOR);
expr := expr + '^';
end;
AS_OR: Begin
Consume(AS_OR);
expr := expr + '|';
end;
AS_ID: Begin
if NOT SearchIConstant(actasmpattern,l) then
Begin
Message1(assem_e_invalid_const_symbol,actasmpattern);
l := 0;
end;
str(l, tempstr);
expr := expr + tempstr;
Consume(AS_ID);
end;
AS_INTNUM: Begin
expr := expr + actasmpattern;
Consume(AS_INTNUM);
end;
AS_BINNUM: Begin
tempstr := BinaryToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_bin);
expr:=expr+tempstr;
Consume(AS_BINNUM);
end;
AS_HEXNUM: Begin
tempstr := HexToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_hex);
expr:=expr+tempstr;
Consume(AS_HEXNUM);
end;
AS_OCTALNUM: Begin
tempstr := OctalToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_octal);
expr:=expr+tempstr;
Consume(AS_OCTALNUM);
end;
{ go to next term }
AS_COMMA: Begin
if not ErrorFlag then
BuildExpression := CalculateExpression(expr)
else
BuildExpression := 0;
Exit;
end;
{ go to next symbol }
AS_SEPARATOR: Begin
if not ErrorFlag then
BuildExpression := CalculateExpression(expr)
else
BuildExpression := 0;
Exit;
end;
else
Begin
{ only write error once. }
if not errorflag then
Message(assem_e_invalid_constant_expression);
{ consume tokens until we find COMMA or SEPARATOR }
Consume(actasmtoken);
errorflag := TRUE;
End;
end;
Until false;
end;
Procedure BuildRealConstant(typ : tfloattype);
{*********************************************************************}
{ PROCEDURE BuilRealConst }
{ Description: This routine calculates a constant expression to }
{ a given value. The return value is the value calculated from }
{ the expression. }
{ The following tokens (not strings) are recognized: }
{ +/-,numbers and real numbers }
{*********************************************************************}
{ ENTRY: On entry the token should be any valid expression token. }
{ EXIT: On Exit the token points to either COMMA or SEPARATOR }
{ ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming }
{ invalid tokens. }
{*********************************************************************}
var expr: string;
tempstr: string;
r : extended;
code : word;
negativ : boolean;
errorflag: boolean;
Begin
errorflag := FALSE;
Repeat
negativ:=false;
expr := '';
tempstr := '';
if actasmtoken=AS_PLUS then Consume(AS_PLUS)
else if actasmtoken=AS_MINUS then
begin
negativ:=true;
consume(AS_MINUS);
end;
Case actasmtoken of
AS_INTNUM: Begin
expr := actasmpattern;
Consume(AS_INTNUM);
end;
AS_REALNUM: Begin
expr := actasmpattern;
{ in ATT syntax you have 0d in front of the real }
{ should this be forced ? yes i think so, as to }
{ conform to gas as much as possible. }
if (expr[1]='0') and (upper(expr[2])='D') then
expr:=copy(expr,3,255);
Consume(AS_REALNUM);
end;
AS_BINNUM: Begin
{ checking for real constants with this should use }
{ real DECODING otherwise the compiler will crash! }
Message(assem_w_float_bin_ignored);
Consume(AS_BINNUM);
end;
AS_HEXNUM: Begin
{ checking for real constants with this should use }
{ real DECODING otherwise the compiler will crash! }
Message(assem_w_float_hex_ignored);
Consume(AS_HEXNUM);
end;
AS_OCTALNUM: Begin
{ checking for real constants with this should use }
{ real DECODING otherwise the compiler will crash! }
{ xxxToDec using reals could be a solution, but the }
{ problem is that these will crash the m68k compiler }
{ when compiling -- because of lack of good fpu }
{ support. }
Message(assem_w_float_octal_ignored);
Consume(AS_OCTALNUM);
end;
else
Begin
{ only write error once. }
if not errorflag then
Message(assem_e_invalid_real_const);
{ consume tokens until we find COMMA or SEPARATOR }
Consume(actasmtoken);
errorflag := TRUE;
End;
end;
{ go to next term }
if (actasmtoken=AS_COMMA) or (actasmtoken=AS_SEPARATOR) then
Begin
if negativ then expr:='-'+expr;
val(expr,r,code);
if code<>0 then
Begin
r:=0;
Message(assem_e_invalid_real_const);
ConcatRealConstant(p,r,typ);
End
else
Begin
ConcatRealConstant(p,r,typ);
End;
end
else
Message(assem_e_invalid_real_const);
Until actasmtoken=AS_SEPARATOR;
end;
Procedure BuildScaling(Var instr: TInstruction);
{*********************************************************************}
{ Takes care of parsing expression starting from the scaling value }
{ up to and including possible field specifiers. }
{ EXIT CONDITION: On exit the routine should point to AS_SEPARATOR }
{ or AS_COMMA. On entry should point to the AS_COMMA token. }
{*********************************************************************}
var str:string;
l: longint;
code: integer;
Begin
Consume(AS_COMMA);
if (instr.operands[operandnum].ref.scalefactor <> 0)
and (instr.operands[operandnum].ref.scalefactor <> 1) then
Message(assem_f_internal_error_in_buildscale);
case actasmtoken of
AS_INTNUM: str := actasmpattern;
AS_HEXNUM: str := HexToDec(actasmpattern);
AS_BINNUM: str := BinaryToDec(actasmpattern);
AS_OCTALNUM: str := OctalToDec(actasmpattern);
else
Message(assem_e_syntax_error);
end;
val(str, l, code);
if code <> 0 then
Message(assem_e_invalid_scaling_factor);
if ((l = 2) or (l = 4) or (l = 8) or (l = 1)) and (code = 0) then
begin
instr.operands[operandnum].ref.scalefactor := l;
end
else
Begin
Message(assem_e_invalid_scaling_value);
instr.operands[operandnum].ref.scalefactor := 0;
end;
if instr.operands[operandnum].ref.index = R_NO then
Begin
Message(assem_e_scaling_value_only_allowed_with_index);
instr.operands[operandnum].ref.scalefactor := 0;
end;
{ Consume the scaling number }
Consume(actasmtoken);
if actasmtoken = AS_RPAREN then
Consume(AS_RPAREN)
else
Message(assem_e_invalid_scaling_value);
{ // .Field.Field ... or separator/comma // }
if actasmtoken in [AS_COMMA,AS_SEPARATOR] then
Begin
end
else
Message(assem_e_syntax_error);
end;
Function BuildRefExpression: longint;
{*********************************************************************}
{ FUNCTION BuildExpression: longint }
{ Description: This routine calculates a constant expression to }
{ a given value. The return value is the value calculated from }
{ the expression. }
{ The following tokens (not strings) are recognized: }
{ SHL,SHR,/,*,NOT,OR,XOR,AND,MOD,+/-,numbers,ID to constants. }
{*********************************************************************}
{ ENTRY: On entry the token should be any valid expression token. }
{ EXIT: On Exit the token points to the LPAREN token. }
{ ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming }
{ invalid tokens. }
{*********************************************************************}
var tempstr: string;
expr: string;
l : longint;
errorflag : boolean;
Begin
errorflag := FALSE;
tempstr := '';
expr := '';
Repeat
Case actasmtoken of
AS_RPAREN: Begin
Message(assem_e_parenthesis_are_not_allowed);
Consume(AS_RPAREN);
end;
AS_SHL: Begin
Consume(AS_SHL);
expr := expr + '<';
end;
AS_SHR: Begin
Consume(AS_SHR);
expr := expr + '>';
end;
AS_SLASH: Begin
Consume(AS_SLASH);
expr := expr + '/';
end;
AS_MOD: Begin
Consume(AS_MOD);
expr := expr + '%';
end;
AS_STAR: Begin
Consume(AS_STAR);
expr := expr + '*';
end;
AS_PLUS: Begin
Consume(AS_PLUS);
expr := expr + '+';
end;
AS_MINUS: Begin
Consume(AS_MINUS);
expr := expr + '-';
end;
AS_AND: Begin
Consume(AS_AND);
expr := expr + '&';
end;
AS_NOT: Begin
Consume(AS_NOT);
expr := expr + '~';
end;
AS_XOR: Begin
Consume(AS_XOR);
expr := expr + '^';
end;
AS_OR: Begin
Consume(AS_OR);
expr := expr + '|';
end;
{ End of reference }
AS_LPAREN: Begin
if not ErrorFlag then
BuildRefExpression := CalculateExpression(expr)
else
BuildRefExpression := 0;
{ no longer in an expression }
exit;
end;
AS_ID:
Begin
if NOT SearchIConstant(actasmpattern,l) then
Begin
Message1(assem_e_invalid_const_symbol,actasmpattern);
l := 0;
end;
str(l, tempstr);
expr := expr + tempstr;
Consume(AS_ID);
end;
AS_INTNUM: Begin
expr := expr + actasmpattern;
Consume(AS_INTNUM);
end;
AS_BINNUM: Begin
tempstr := BinaryToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_bin);
expr:=expr+tempstr;
Consume(AS_BINNUM);
end;
AS_HEXNUM: Begin
tempstr := HexToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_hex);
expr:=expr+tempstr;
Consume(AS_HEXNUM);
end;
AS_OCTALNUM: Begin
tempstr := OctalToDec(actasmpattern);
if tempstr = '' then
Message(assem_f_error_converting_octal);
expr:=expr+tempstr;
Consume(AS_OCTALNUM);
end;
else
Begin
{ write error only once. }
if not errorflag then
Message(assem_e_invalid_constant_expression);
BuildRefExpression := 0;
if actasmtoken in [AS_COMMA,AS_SEPARATOR] then exit;
{ consume tokens until we find COMMA or SEPARATOR }
Consume(actasmtoken);
errorflag := TRUE;
end;
end;
Until false;
end;
Procedure BuildReference(var Instr: TInstruction);
{*********************************************************************}
{ PROCEDURE BuildBracketExpression }
{ Description: This routine builds up an expression after a LPAREN }
{ token is encountered. }
{ On entry actasmtoken should be equal to AS_LPAREN }
{*********************************************************************}
{ EXIT CONDITION: On exit the routine should point to either the }
{ AS_COMMA or AS_SEPARATOR token. }
{*********************************************************************}
var
l:longint;
code: integer;
str: string;
Begin
Consume(AS_LPAREN);
initAsmRef(instr);
Case actasmtoken of
{ // (reg ... // }
AS_REGISTER: Begin
instr.operands[operandnum].ref.base :=
findregister(actasmpattern);
Consume(AS_REGISTER);
{ can either be a register or a right parenthesis }
{ // (reg) // }
if actasmtoken=AS_RPAREN then Begin
Consume(AS_RPAREN);
if not (actasmtoken in [AS_COMMA,
AS_SEPARATOR]) then
Begin
Message(assem_e_invalid_reference);
{ error recovery ... }
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
exit;
end;
{ // (reg,reg .. // }
{ we need a comman here !! }
{ oops.. }
Consume(AS_COMMA);
Case actasmtoken of
AS_REGISTER: Begin
instr.operands[operandnum].ref.index :=
findregister(actasmpattern);
Consume(AS_REGISTER);
{ check for scaling ... }
case actasmtoken of
AS_RPAREN:
Begin
Consume(AS_RPAREN);
if not (actasmtoken in [AS_COMMA,
AS_SEPARATOR]) then
Begin
{ error recovery ... }
Message(assem_e_invalid_reference);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
exit;
end;
AS_COMMA:
Begin
BuildScaling(instr);
end;
else
Begin
Message(assem_e_invalid_reference_syntax);
while (actasmtoken <> AS_SEPARATOR) do
Consume(actasmtoken);
end;
end; { end case }
end;
else
Begin
Message(assem_e_invalid_reference_syntax);
while (actasmtoken <> AS_SEPARATOR) do
Consume(actasmtoken);
end;
end; {end case }
end;
{ // (, ... // }
AS_COMMA: { can either be scaling, or index }
Begin
Consume(AS_COMMA);
case actasmtoken of
AS_REGISTER: Begin
instr.operands[operandnum].ref.index :=
findregister(actasmpattern);
Consume(AS_REGISTER);
{ check for scaling ... }
case actasmtoken of
AS_RPAREN:
Begin
Consume(AS_RPAREN);
if not (actasmtoken in [AS_COMMA,
AS_SEPARATOR]) then
Begin
{ error recovery ... }
Message(assem_e_invalid_reference);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
exit;
end;
AS_COMMA:
Begin
BuildScaling(instr);
end;
else
Begin
Message(assem_e_invalid_reference_syntax);
while (actasmtoken <> AS_SEPARATOR) do
Consume(actasmtoken);
end;
end; {end case }
end;
AS_HEXNUM,AS_INTNUM, { we have to process the scaling }
AS_BINNUM,AS_OCTALNUM: { directly here... }
Begin
case actasmtoken of
AS_INTNUM: str :=
actasmpattern;
AS_HEXNUM: str :=
HexToDec(actasmpattern);
AS_BINNUM: str :=
BinaryToDec(actasmpattern);
AS_OCTALNUM: str :=
OctalToDec(actasmpattern);
else
Message(assem_e_syntax_error);
end; { end case }
val(str, l, code);
if code <> 0 then
Message(assem_e_invalid_scaling_factor);
if ((l = 2) or (l = 4) or (l = 8) or (l = 1)) and (code = 0) then
begin
instr.operands[operandnum].
ref.scalefactor := l;
end
else
Begin
Message(assem_e_invalid_scaling_value);
instr.operands[operandnum].
ref.scalefactor := 0;
end;
Consume(actasmtoken);
if actasmtoken <> AS_RPAREN then
Begin
Message(assem_e_invalid_scaling_value);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end
else
Begin
Consume(AS_RPAREN);
if not (actasmtoken in [AS_COMMA,
AS_SEPARATOR]) then
Begin
{ error recovery ... }
Message(assem_e_invalid_reference);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
exit;
end;
end;
else
Begin
Message(assem_e_invalid_reference_syntax);
while (actasmtoken <> AS_SEPARATOR) do
Consume(actasmtoken);
end;
end; { end case }
end;
else
Begin
Message(assem_e_invalid_reference_syntax);
while (actasmtoken <> AS_SEPARATOR) do
Consume(actasmtoken);
end;
end; { end case }
end;
Procedure BuildOperand(var instr: TInstruction);
{*********************************************************************}
{ EXIT CONDITION: On exit the routine should point to either the }
{ AS_COMMA or AS_SEPARATOR token. }
{*********************************************************************}
var
tempstr: string;
expr: string;
lab: Pasmlabel;
hl: plabel;
Begin
tempstr := '';
expr := '';
case actasmtoken of
{ // Memory reference // }
AS_LPAREN:
Begin
initAsmRef(instr);
BuildReference(instr);
end;
{ // Constant expression // }
AS_DOLLAR: Begin
Consume(AS_DOLLAR);
if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then
Message(assem_e_invalid_operand_type);
{ identifiers are handled by BuildExpression }
instr.operands[operandnum].operandtype := OPR_CONSTANT;
instr.operands[operandnum].val :=BuildExpression;
end;
{ // Constant memory offset . // }
{ // This must absolutely be followed by ( // }
AS_HEXNUM,AS_INTNUM,AS_MINUS,
AS_BINNUM,AS_OCTALNUM,AS_PLUS:
Begin
InitAsmRef(instr);
instr.operands[operandnum].ref.offset:=BuildRefExpression;
BuildReference(instr);
end;
{ // A constant expression, or a Variable ref. // }
AS_ID: Begin
{ // Local label. // }
if (actasmpattern[1] ='.') and (actasmpattern[2] = 'L') then
Begin
Begin
delete(actasmpattern,1,1);
delete(actasmpattern,1,1);
if actasmpattern = '' then
Message(assem_e_null_label_ref_not_allowed);
lab := labellist.search(actasmpattern);
{ check if the label is already defined }
{ if so, we then check if the plabel is }
{ non-nil, if so we add it to instruction }
if assigned(lab) then
Begin
if assigned(lab^.lab) then
Begin
instr.operands[operandnum].operandtype := OPR_LABINSTR;
instr.operands[operandnum].hl := lab^.lab;
instr.labeled := TRUE;
end;
end
else
{ the label does not exist, create it }
{ emit the opcode, but set that the }
{ label has not been emitted }
Begin
getlabel(hl);
labellist.insert(actasmpattern,hl,FALSE);
instr.operands[operandnum].operandtype := OPR_LABINSTR;
instr.operands[operandnum].hl := hl;
instr.labeled := TRUE;
end;
end;
Consume(AS_ID);
if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
Begin
Message(assem_e_syntax_error);
end;
end
{ probably a variable or normal expression }
{ or a procedure (such as in CALL ID) }
else
Begin
{ check if this is a label, if so then }
{ emit it as a label. }
if SearchLabel(actasmpattern,hl) then
Begin
instr.operands[operandnum].operandtype := OPR_LABINSTR;
instr.operands[operandnum].hl := hl;
instr.labeled := TRUE;
Consume(AS_ID);
if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
Message(assem_e_syntax_error);
end
else
{ is it a normal variable ? }
Begin
initAsmRef(instr);
if not CreateVarInstr(instr,actasmpattern,operandnum) then
Begin
{ look for special symbols ... }
if actasmpattern = '__RESULT' then
SetUpResult(instr,operandnum)
else
if actasmpattern = '__SELF' then
Begin
if assigned(procinfo._class) then
Begin
instr.operands[operandnum].operandtype := OPR_REFERENCE;
instr.operands[operandnum].ref.offset :=
procinfo.ESI_offset;
instr.operands[operandnum].ref.base :=
procinfo.framepointer;
end
else
Message(assem_e_cannot_use___SELF_outside_methode);
end
else
if actasmpattern = '__OLDEBP' then
Begin
if lexlevel>2 then
Begin
instr.operands[operandnum].operandtype := OPR_REFERENCE;
instr.operands[operandnum].ref.offset :=
procinfo.framepointer_offset;
instr.operands[operandnum].ref.base :=
procinfo.framepointer;
end
else
Message(assem_e_cannot_use___OLDEBP_outside_nested_procedure);
end { endif actasmpattern = '__OLDEBP' }
else
{ check for direct symbolic names }
{ only if compiling the system unit }
if (cs_compilesystem in aktswitches) then
begin
if not SearchDirectVar(instr,actasmpattern,operandnum) then
Begin
{ not found, finally ... add it anyways ... }
Message1(assem_w_id_supposed_external,actasmpattern);
instr.operands[operandnum].ref.symbol := newpasstr(actasmpattern);
end;
end
else
Message1(assem_e_unknown_id,actasmpattern);
end;
expr := actasmpattern;
Consume(AS_ID);
case actasmtoken of
AS_LPAREN: { indexing }
BuildReference(instr);
AS_SEPARATOR,AS_COMMA: ;
else
Message(assem_e_syntax_error);
end; { end case }
end; { end if }
end; { end if }
end; { end this case }
{ // Register, a variable reference or a constant reference // }
AS_REGISTER: Begin
{ save the type of register used. }
tempstr := actasmpattern;
Consume(AS_REGISTER);
if actasmtoken = AS_COLON then
Begin
Consume(AS_COLON);
initAsmRef(instr);
instr.operands[operandnum].ref.segment := findsegment(tempstr);
{ here we can have either an identifier }
{ or a constant, where either can be }
{ followed by a parenthesis... }
{ // Constant memory offset . // }
{ // This must absolutely be followed by ( // }
case actasmtoken of
AS_HEXNUM,AS_INTNUM,AS_MINUS,
AS_BINNUM,AS_OCTALNUM,AS_PLUS
: Begin
instr.operands[operandnum].
ref.offset:=BuildRefExpression;
BuildReference(instr);
end;
AS_LPAREN: BuildReference(instr);
{ only a variable is allowed ... }
AS_ID: Begin
{ is it a normal variable ? }
if not CreateVarInstr(instr,actasmpattern,operandnum)
then
begin
{ check for direct symbolic names }
{ only if compiling the system unit }
if (cs_compilesystem in aktswitches) then
begin
if not SearchDirectVar(instr,actasmpattern,operandnum) then
Message(assem_e_invalid_seg_override);
end
else
Message(assem_e_invalid_seg_override);
end;
Consume(actasmtoken);
case actasmtoken of
AS_SEPARATOR,AS_COMMA: ;
AS_LPAREN: BuildReference(instr);
else
Begin
Message(assem_e_invalid_seg_override);
Consume(actasmtoken);
end;
end; {end case }
end;
else
Begin
Message(assem_e_invalid_seg_override);
Consume(actasmtoken);
end;
end; { end case }
end
{ // Simple register // }
else if (actasmtoken = AS_SEPARATOR) or (actasmtoken = AS_COMMA) then
Begin
if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_REGISTER]) then
Message(assem_e_invalid_operand_type);
instr.operands[operandnum].operandtype := OPR_REGISTER;
instr.operands[operandnum].reg := findregister(tempstr);
end
else
Message1(assem_e_syn_register,tempstr);
end;
AS_SEPARATOR, AS_COMMA: ;
else
Begin
Message(assem_e_syn_opcode_operand);
Consume(actasmtoken);
end;
end; { end case }
end;
Procedure BuildConstant(maxvalue: longint);
{*********************************************************************}
{ PROCEDURE BuildConstant }
{ Description: This routine takes care of parsing a DB,DD,or DW }
{ line and adding those to the assembler node. Expressions, range- }
{ checking are fullly taken care of. }
{ maxvalue: $ff -> indicates that this is a DB node. }
{ $ffff -> indicates that this is a DW node. }
{ $ffffffff -> indicates that this is a DD node. }
{*********************************************************************}
{ EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. }
{*********************************************************************}
var
strlength: byte;
expr: string;
value : longint;
Begin
Repeat
Case actasmtoken of
AS_STRING: Begin
if maxvalue = $ff then
strlength := 1
else
Message(assem_e_string_not_allowed_as_const);
expr := actasmpattern;
if length(expr) > 1 then
Message(assem_e_string_not_allowed_as_const);
Consume(AS_STRING);
Case actasmtoken of
AS_COMMA: Consume(AS_COMMA);
AS_SEPARATOR: ;
else
Message(assem_e_invalid_string_expression);
end; { end case }
ConcatString(p,expr);
end;
AS_INTNUM,AS_BINNUM,
AS_OCTALNUM,AS_HEXNUM:
Begin
value:=BuildExpression;
ConcatConstant(p,value,maxvalue);
end;
AS_ID:
Begin
value:=BuildExpression;
if value > maxvalue then
Begin
Message(assem_e_expression_out_of_bounds);
{ assuming a value of maxvalue }
value := maxvalue;
end;
ConcatConstant(p,value,maxvalue);
end;
{ These terms can start an assembler expression }
AS_PLUS,AS_MINUS,AS_LPAREN,AS_NOT: Begin
value := BuildExpression;
ConcatConstant(p,value,maxvalue);
end;
AS_COMMA: BEGIN
Consume(AS_COMMA);
END;
AS_SEPARATOR: ;
else
Begin
Message(assem_f_internal_error_in_buildconstant);
end;
end; { end case }
Until actasmtoken = AS_SEPARATOR;
end;
Procedure BuildStringConstant(asciiz: boolean);
{*********************************************************************}
{ PROCEDURE BuildStringConstant }
{ Description: Takes care of a ASCII, or ASCIIZ directive. }
{ asciiz: boolean -> if true then string will be null terminated. }
{*********************************************************************}
{ EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. }
{ On ENTRY: Token should point to AS_STRING }
{*********************************************************************}
var
expr: string;
errorflag : boolean;
Begin
errorflag := FALSE;
Repeat
Case actasmtoken of
AS_STRING: Begin
expr:=actasmpattern;
if asciiz then
expr:=expr+#0;
ConcatPasString(p,expr);
Consume(AS_STRING);
end;
AS_COMMA: BEGIN
Consume(AS_COMMA);
END;
AS_SEPARATOR: ;
else
Begin
Consume(actasmtoken);
if not errorflag then
Message(assem_e_invalid_string_expression);
errorflag := TRUE;
end;
end; { end case }
Until actasmtoken = AS_SEPARATOR;
end;
Procedure BuildOpCode;
{*********************************************************************}
{ PROCEDURE BuildOpcode; }
{ Description: Parses the intel opcode and operands, and writes it }
{ in the TInstruction object. }
{*********************************************************************}
{ EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. }
{ On ENTRY: Token should point to AS_OPCODE }
{*********************************************************************}
var asmtok: tasmop;
op: tasmop;
expr: string;
segreg: tregister;
Begin
expr := '';
asmtok := A_NONE; { assmume no prefix }
segreg := R_NO; { assume no segment override }
{ // prefix seg opcode // }
{ // prefix opcode // }
if findprefix(actasmpattern,asmtok) then
Begin
{ standard opcode prefix }
if asmtok <> A_NONE then
instr.addprefix(asmtok);
Consume(AS_OPCODE);
end;
{ // opcode // }
{ allow for newline as in gas styled syntax }
{ under DOS you get two AS_SEPARATOR !! }
while actasmtoken=AS_SEPARATOR do
Consume(AS_SEPARATOR);
if (actasmtoken <> AS_OPCODE) then
Begin
Message(assem_e_invalid_or_missing_opcode);
{ error recovery }
While not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
Consume(actasmtoken);
exit;
end
else
Begin
op := findopcode(actasmpattern);
instr.addinstr(op);
{ // Valid combination of prefix and instruction ? // }
if (asmtok <> A_NONE) and (NOT CheckPrefix(asmtok,op)) then
Message1(assem_e_invalid_prefix_and_opcode,actasmpattern);
Consume(AS_OPCODE);
{ // Zero operand opcode ? // }
if actasmtoken = AS_SEPARATOR then
exit
else
operandnum := 1;
end;
While actasmtoken <> AS_SEPARATOR do
Begin
case actasmtoken of
{ // Operand delimiter // }
AS_COMMA: Begin
if operandnum > MaxOperands then
Message(assem_e_too_many_operands)
else
Inc(operandnum);
Consume(AS_COMMA);
end;
{ // End of asm operands for this opcode // }
AS_SEPARATOR: ;
else
BuildOperand(instr);
end; { end case }
end; { end while }
end;
Function Assemble: Ptree;
{*********************************************************************}
{ PROCEDURE Assemble; }
{ Description: Parses the att assembler syntax, parsing is done }
{ according to GAs rules. }
{*********************************************************************}
Var
hl: plabel;
labelptr,nextlabel : pasmlabel;
commname : string;
store_p : paasmoutput;
Begin
Message(assem_d_start_att);
firsttoken := TRUE;
operandnum := 0;
if assigned(procinfo.retdef) and
(is_fpu(procinfo.retdef) or
ret_in_acc(procinfo.retdef)) then
procinfo.funcret_is_valid:=true;
{ sets up all opcode and register tables in uppercase }
if not _asmsorted then
Begin
SetupTables;
_asmsorted := TRUE;
end;
p:=new(paasmoutput,init);
{ save pointer code section }
store_p:=p;
{ setup label linked list }
labellist.init;
c:=asmgetchar;
actasmtoken:=gettoken;
while actasmtoken<>AS_END do
Begin
case actasmtoken of
AS_LLABEL: Begin
labelptr := labellist.search(actasmpattern);
if not assigned(labelptr) then
Begin
getlabel(hl);
labellist.insert(actasmpattern,hl,TRUE);
ConcatLabel(p,A_LABEL,hl);
end
else
{ the label has already been inserted into the }
{ label list, either as an instruction label (in}
{ this case it has not been emitted), or as a }
{ duplicate local symbol (in this case it has }
{ already been emitted). }
Begin
if labelptr^.emitted then
Message1(assem_e_dup_local_sym,'.L'+labelptr^.name^)
else
Begin
if assigned(labelptr^.lab) then
ConcatLabel(p,A_LABEL,labelptr^.lab);
labelptr^.emitted := TRUE;
end;
end;
Consume(AS_LLABEL);
end;
AS_LABEL: Begin
{ when looking for Pascal labels, these must }
{ be in uppercase. }
if SearchLabel(upper(actasmpattern),hl) then
ConcatLabel(p,A_LABEL, hl)
else
Begin
if (cs_compilesystem in aktswitches) then
begin
Message1(assem_e_unknown_label_identifer,actasmpattern);
{ once again we don't know what it represents }
{ so we simply concatenate it }
ConcatLocal(p,actasmpattern);
end
else
Message1(assem_e_unknown_label_identifer,actasmpattern);
end;
Consume(AS_LABEL);
end;
AS_DW: Begin
Consume(AS_DW);
BuildConstant($ffff);
end;
AS_DATA: Begin
{ -- this should only be allowed for system development -- }
{ i think this should be fixed in the dos unit, and }
{ not here. }
if (cs_compilesystem in aktswitches) then
p:=datasegment
else
Message(assem_e_switching_sections_not_allowed);
Consume(AS_DATA);
end;
AS_TEXT: Begin
{ -- this should only be allowed for system development -- }
{ i think this should be fixed in the dos unit, and }
{ not here. }
if (cs_compilesystem in aktswitches) then
p:=store_p
else
Message(assem_e_switching_sections_not_allowed);
Consume(AS_TEXT);
end;
AS_DB: Begin
Consume(AS_DB);
BuildConstant($ff);
end;
AS_DD: Begin
Consume(AS_DD);
BuildConstant($ffffffff);
end;
AS_DQ: Begin
Consume(AS_DQ);
BuildRealConstant(s64bit);
end;
AS_SINGLE: Begin
Consume(AS_SINGLE);
BuildRealConstant(s32real);
end;
AS_DOUBLE: Begin
Consume(AS_DOUBLE);
BuildRealConstant(s64real);
end;
AS_EXTENDED: Begin
Consume(AS_EXTENDED);
BuildRealConstant(s80real);
end;
AS_GLOBAL:
Begin
{ normal units should not be able to declare }
{ direct label names like this... anyhow }
{ procedural calls in asm blocks are }
{ supposedely replaced automatically }
if (cs_compilesystem in aktswitches) then
begin
Consume(AS_GLOBAL);
if actasmtoken <> AS_ID then
Message(assem_e_invalid_global_def)
else
ConcatPublic(p,actasmpattern);
Consume(actasmtoken);
if actasmtoken <> AS_SEPARATOR then
Begin
Message(assem_e_line_separator_expected);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end
else
begin
Message(assem_w_globl_not_supported);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end;
AS_ALIGN: Begin
Message(assem_w_align_not_supported);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
AS_ASCIIZ: Begin
Consume(AS_ASCIIZ);
BuildStringConstant(TRUE);
end;
AS_ASCII: Begin
Consume(AS_ASCII);
BuildStringConstant(FALSE);
end;
AS_LCOMM: Begin
{ -- this should only be allowed for system development -- }
{ -- otherwise may mess up future enhancements we might -- }
{ -- add. -- }
if (cs_compilesystem in aktswitches) then
begin
Consume(AS_LCOMM);
if actasmtoken <> AS_ID then
begin
Message(assem_e_invalid_lcomm_def);
{ error recovery }
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end
else
begin
commname:=actasmpattern;
Consume(AS_COMMA);
ConcatLocalBss(actasmpattern,BuildExpression);
if actasmtoken <> AS_SEPARATOR then
Begin
Message(assem_e_line_separator_expected);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end;
end
else
begin
Message(assem_w_lcomm_not_supported);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end;
AS_COMM: Begin
{ -- this should only be allowed for system development -- }
{ -- otherwise may mess up future enhancements we might -- }
{ -- add. -- }
if (cs_compilesystem in aktswitches) then
begin
Consume(AS_LCOMM);
if actasmtoken <> AS_ID then
begin
Message(assem_e_invalid_comm_def);
{ error recovery }
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end
else
begin
commname:=actasmpattern;
Consume(AS_COMMA);
ConcatGlobalBss(actasmpattern,BuildExpression);
if actasmtoken <> AS_SEPARATOR then
Begin
Message(assem_e_line_separator_expected);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end;
end
else
begin
Message(assem_w_comm_not_supported);
while actasmtoken <> AS_SEPARATOR do
Consume(actasmtoken);
end;
end;
AS_OPCODE: Begin
instr.init;
BuildOpcode;
instr.numops := operandnum;
if instr.labeled then
ConcatLabeledInstr(instr)
else
ConcatOpCode(instr);
end;
AS_SEPARATOR:Begin
Consume(AS_SEPARATOR);
{ let us go back to the first operand }
operandnum := 0;
end;
AS_END: ; { end assembly block }
else
Begin
Message(assem_e_assemble_node_syntax_error);
{ error recovery }
Consume(actasmtoken);
end;
end; { end case }
end; { end while }
{ check if there were undefined symbols. }
{ if so, then list each of those undefined }
{ labels. }
if assigned(labellist.First) then
Begin
labelptr := labellist.First;
While labelptr <> nil do
Begin
nextlabel:=labelptr^.next;
if not labelptr^.emitted then
Message1(assem_e_local_sym_not_found_in_asm_statement,'.L'+labelptr^.name^);
labelptr:=nextlabel;
end;
end;
if p<>store_p then
begin
Message(assem_e_assembler_code_not_returned_to_text);
p:=store_p;
end;
assemble := genasmnode(p);
labellist.done;
Message(assem_d_finish_att);
end;
var
old_exit: pointer;
procedure ratti386_exit;{$ifndef FPC}far;{$endif}
begin
if assigned(iasmops) then
dispose(iasmops);
exitproc:=old_exit;
end;
Begin
line:=''; { Initialization of line variable.
No 255 char coonst string in version 0.9.1 MVC}
old_exit := exitproc;
exitproc := @ratti386_exit;
end.
{
$Log$
Revision 1.3 1998-04-08 16:58:07 pierre
* several bugfixes
ADD ADC and AND are also sign extended
nasm output OK (program still crashes at end
and creates wrong assembler files !!)
procsym types sym in tdef removed !!
Revision 1.2 1998/03/30 15:53:01 florian
* last changes before release:
- gdb fixed
- ratti386 warning removed (about unset function result)
Revision 1.1.1.1 1998/03/25 11:18:15 root
* Restored version
Revision 1.21 1998/03/10 16:27:44 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.20 1998/03/10 01:17:27 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.19 1998/03/09 12:58:13 peter
* FWait warning is only showed for Go32V2 and $E+
* opcode tables moved to i386.pas/m68k.pas to reduce circular uses (and
for m68k the same tables are removed)
+ $E for i386
Revision 1.18 1998/03/04 17:34:01 michael
+ Changed ifdef FPK to ifdef FPC
Revision 1.17 1998/03/03 22:38:30 peter
* the last 3 files
Revision 1.16 1998/03/02 01:49:21 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.15 1998/02/13 10:35:42 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.14 1998/02/12 11:50:41 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.13 1998/02/07 18:03:55 carl
+ fwait warning for emulation
Revision 1.12 1998/01/19 03:10:52 carl
* bugfix number 78
Revision 1.11 1998/01/09 19:24:00 carl
+ externals are now added if identifier is not found
Revision 1.10 1997/12/14 22:43:25 florian
+ command line switch -Xs for DOS (passes -s to the linker to strip symbols from
executable)
* some changes of Carl-Eric implemented
Revision 1.9 1997/12/09 14:07:14 carl
+ added better error size checkimg -- otherwise would cause problems
with intasmi3
* bugfixes as in rai386
* BuildRealConstant gave out Overflow errors (hex/bin/octal should be
directly decoded into real)
* bugfix of MOVSX/MOVZX instruction
* ConcatOpCode op_csymbol gave out a Runerrore 216 under each test
I performed, or output a nil symbol -- so removed.
* All identifiers must be in uppercase!!!
(except local labels and directives)
+ supervisor stuff only possible when compiling the system unit
Revision 1.7 1997/12/04 12:21:09 pierre
+* MMX instructions added to att output with a warning that
GNU as version >= 2.81 is needed
bug in reading of reals under att syntax corrected
Revision 1.6 1997/12/01 17:42:56 pierre
+ added some more functionnality to the assembler parser
Revision 1.5 1997/11/28 15:43:23 florian
Fixed stack ajustment bug, 0.9.8 compiles now 0.9.8 without problems.
Revision 1.4 1997/11/28 15:39:46 carl
- removed reference to WriteLn and replaced in inasmxxx
* uncommented firstop and lastop (otherwise can cause bugs)
Revision 1.3 1997/11/28 14:26:24 florian
Fixed some bugs
Revision 1.2 1997/11/28 12:05:44 michael
Changed comment delimiter to braces
CHanged use of ord to typecast with longint
Changed line constant to variable. Added initialization. v0.9.1 chokes
on 255 length constant strings.
Boolean expressions are now non-redundant.
Revision 1.1.1.1 1997/11/27 08:33:01 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
14th november 1997:
* fixed bug regarding ENTER and push imm8 instruction (CEC)
+ fixed conflicts with fpu instructions. (CEC).
+ adding real const support. (PM).
}
Reference in New Issue View Git Blame Copy Permalink