paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-12 16:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity
6fb9e55bb3
fpc/compiler/radi386.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

315 lines
14 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998 by Florian Klaempfl
Reads inline assembler and writes the lines direct to the output
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 radi386;
interface
uses
tree;
function assemble : ptree;
implementation
uses
i386,hcodegen,globals,scanner,aasm,
cobjects,symtable,types,verbose,asmutils;
function assemble : ptree;
var
retstr,s,hs : string;
c : char;
ende : boolean;
sym : psym;
code : paasmoutput;
l : longint;
procedure writeasmline;
var
i : longint;
begin
i:=length(s);
while (i>0) and (s[i] in [' ',#9]) do
dec(i);
s[0]:=chr(i);
if s<>'' then
code^.concat(new(pai_direct,init(strpnew(s))));
{ consider it set function set if the offset was loaded }
if assigned(procinfo.retdef) and
(pos(retstr,upper(s))>0) then
procinfo.funcret_is_valid:=true;
s:='';
end;
begin
ende:=false;
s:='';
if assigned(procinfo.retdef) and
is_fpu(procinfo.retdef) then
procinfo.funcret_is_valid:=true;
if assigned(procinfo.retdef) and
(procinfo.retdef<>pdef(voiddef)) then
retstr:=upper(tostr(procinfo.retoffset)+'('+att_reg2str[procinfo.framepointer]+')')
else
retstr:='';
c:=asmgetchar;
code:=new(paasmoutput,init);
while not(ende) do
begin
case c of
'A'..'Z','a'..'z','_' : begin
hs:='';
while ((ord(c)>=ord('A')) and (ord(c)<=ord('Z')))
or ((ord(c)>=ord('a')) and (ord(c)<=ord('z')))
or ((ord(c)>=ord('0')) and (ord(c)<=ord('9')))
or (c='_') do
begin
inc(byte(hs[0]));
hs[length(hs)]:=c;
c:=asmgetchar;
end;
if upper(hs)='END' then
ende:=true
else
begin
if c=':' then
begin
getsym(upper(hs),false);
if srsym<>nil then
Message(assem_w_using_defined_as_local);
end;
if upper(hs)='FWAIT' then
FwaitWarning
else
{ access to local variables }
if assigned(aktprocsym) then
begin
{ is the last written character an special }
{ char ? }
if (s[length(s)]='%') and
ret_in_acc(procinfo.retdef) and
((pos('AX',upper(hs))>0) or
(pos('AL',upper(hs))>0)) then
procinfo.funcret_is_valid:=true;
if (s[length(s)]<>'%') and
(s[length(s)]<>'$') and
((s[length(s)]<>'0') or (hs[1]<>'x')) then
begin
if assigned(aktprocsym^.definition^.localst) then
sym:=aktprocsym^.definition^.localst^.search(upper(hs))
else
sym:=nil;
if assigned(sym) then
begin
if sym^.typ=varsym then
begin
{variables set are after a comma }
{like in movl %eax,I }
if pos(',',s) > 0 then
pvarsym(sym)^.is_valid:=1
else
if (pos('MOV',upper(s)) > 0) and (pvarsym(sym)^.is_valid=0) then
Message1(sym_n_local_var_not_init_yet,hs);
hs:='-'+tostr(pvarsym(sym)^.address)+'('+att_reg2str[procinfo.framepointer]+')';
end
else
{ call to local function }
if (sym^.typ=procsym) and (pos('CALL',upper(s))>0) then
begin
hs:=pprocsym(sym)^.definition^.mangledname;
end;
end
else
begin
if assigned(aktprocsym^.definition^.parast) then
sym:=aktprocsym^.definition^.parast^.search(upper(hs))
else
sym:=nil;
if assigned(sym) then
begin
if sym^.typ=varsym then
begin
l:=pvarsym(sym)^.address;
{ set offset }
inc(l,aktprocsym^.definition^.parast^.call_offset);
hs:=tostr(l)+'('+att_reg2str[procinfo.framepointer]+')';
if pos(',',s) > 0 then
pvarsym(sym)^.is_valid:=1;
end;
end
{ I added that but it creates a problem in line.ppi
because there is a local label wbuffer and
a static variable WBUFFER ...
what would you decide, florian ?
else
begin
getsym(upper(hs),false);
sym:=srsym;
if assigned(sym) and (sym^.typ = varsym)
or (sym^.typ = typedconstsym) then
hs:=sym^.mangledname;
if (sym^.typ=procsym) and (pos('CALL',upper(s))>0) then
begin
if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
begin
exterror:=strpnew(' calling an overloaded procedure in asm');
warning(user_defined);
end;
hs:=pprocsym(sym)^.definition^.mangledname;
end;
end }
else if upper(hs)='__SELF' then
begin
if assigned(procinfo._class) then
hs:=tostr(procinfo.ESI_offset)+'('+att_reg2str[procinfo.framepointer]+')'
else
Message(assem_e_cannot_use_SELF_outside_a_method);
end
else if upper(hs)='__RESULT' then
begin
if assigned(procinfo.retdef) and
(procinfo.retdef<>pdef(voiddef)) then
begin
hs:=retstr;
end
else
Message(assem_w_void_function);
end
else if upper(hs)='__OLDEBP' then
begin
{ complicate to check there }
{ we do it: }
if lexlevel>2 then
hs:=tostr(procinfo.framepointer_offset)
+'('+att_reg2str[procinfo.framepointer]+')'
else
Message(assem_e_cannot_use___OLDEBP_outside_nested_procedure);
end;
end;
{ end;}
end;
end;
s:=s+hs;
end;
end;
'{',';',#10,#13 : begin
if pos(retstr,s) > 0 then
procinfo.funcret_is_valid:=true;
writeasmline;
c:=asmgetchar;
end;
#26 : Message(scan_f_end_of_file);
else
begin
inc(byte(s[0]));
s[length(s)]:=c;
c:=asmgetchar;
end;
end;
end;
writeasmline;
assemble:=genasmnode(code);
end;
end.
{
$Log$
Revision 1.2 1998-04-08 16:58:06 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.1.1.1 1998/03/25 11:18:15 root
* Restored version
Revision 1.13 1998/03/24 21:48:33 florian
* just a couple of fixes applied:
- problem with fixed16 solved
- internalerror 10005 problem fixed
- patch for assembler reading
- small optimizer fix
- mem is now supported
Revision 1.12 1998/03/10 16:27:43 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.11 1998/03/10 01:17:26 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.10 1998/03/09 12:58:12 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.9 1998/03/06 00:52:51 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.8 1998/03/03 16:45:23 peter
+ message support for assembler parsers
Revision 1.7 1998/03/02 01:49:14 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.6 1998/02/13 10:35:35 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.5 1998/02/07 18:01:27 carl
+ fwait warning for emulation
Revision 1.3 1997/11/30 18:12:17 carl
* bugfix of line numbering.
Revision 1.2 1997/11/28 18:14:44 pierre
working version with several bug fixes
Revision 1.1.1.1 1997/11/27 08:33:00 michael
FPC Compiler CVS start
Pre-CVS log:
History:
19th october 1996:
+ created from old asmbl.pas
13th october 1996:
+ renamed to radi386
}
Reference in New Issue View Git Blame Copy Permalink